How to copy a specific range from one worksheet to another worksheet in another workbook-CodePudding

I have two workbooks: Source.xlsm, sheet= Orig and Destination.xlsm, sheet=New

I am trying to move data between these sheets in a specific way: Example of both sheets before running the macro (the column ordering is on purpose)

In the Orig sheet, cell F1 is storing today's date in the following format: dd mmm yy

My objective is to take only the rows from Orig with today's date and place all of them in a specific ordering to the end of the New sheet. So that after running the macro, New looks like:

Any suggestions as to how to progress would be amazing

I have the following code snippets to start to form a solution, all saved in Source.xlsm. This correctly select the bottom two rows of Orig since they have todays date in column D

Sub SelectTodayRows()
    Dim tableR As Range, cell As Range, r As Range
    Dim s As String
    Set tableR = Range("D1:D100000")
    Set r = Range("F1") 
    For Each cell In tableR
      If cell = r Then
      s = s & cell.Row & ":" & cell.Row & ", "
      End If
    Next cell
    s = Left(s, Len(s) - 2)
    Range(s).Select
   
End Sub

The next step is appending these selected rows in the correct column ordering to New.

CodePudding user response：

Copy Data to Different Columns

Sub TransferToday()
    
    Const CriteriaColumn As Variant = 4
    ' The leading "0, "-s are used to be able to use sCols(c)
    ' instead of sCols(c - 1) in the For...Next loop.
    Dim sCols() As Variant: sCols = VBA.Array(0, 1, 2, 3, 4)
    Dim dCols() As Variant: dCols = VBA.Array(0, 2, 4, 3, 1)
    
    Dim cCount As Long: cCount = UBound(sCols)
    Dim Today As Date: Today = Date ' TODAY() in excel
    
    Dim dwb As Workbook: Set dwb = Workbooks("Destination.xlsm")
    Dim dws As Worksheet: Set dws = dwb.Worksheets("New")
    Dim drg As Range: Set drg = dws.Range("A1").CurrentRegion.Resize(, cCount)
    
    ' Prevent copying if an occurrence of today's date is found in destination.
    ' If not needed, out-comment or delete, it doesn't interfere with the rest.
    Dim dCol As Variant
    dCol = dCols(Application.Match(CriteriaColumn, sCols, 0) - 1)
    If IsNumeric(Application.Match(CLng(Today), drg.Columns(dCol), 0)) Then
        MsgBox "Today's data had already been transferred.", vbExclamation
        Exit Sub
    End If
    
    Dim swb As Workbook: Set swb = ThisWorkbook ' workbook containing this code
    Dim sws As Worksheet: Set sws = swb.Worksheets("Orig")
    Dim srg As Range: Set srg = sws.Range("A1").CurrentRegion.Resize(, cCount)
    Dim srCount As Long: srCount = srg.Rows.Count
    Dim sData() As Variant: sData = srg.Value
    
    Dim dData() As Variant: ReDim dData(1 To srCount, 1 To cCount)
    
    Dim sr As Long
    Dim dr As Long
    Dim c As Long
    
    For sr = 1 To srCount
        If IsDate(sData(sr, CriteriaColumn)) Then ' is a date
            If sData(sr, CriteriaColumn) = Today Then ' is today's date
                dr = dr   1
                For c = 1 To cCount
                    dData(dr, dCols(c)) = sData(sr, sCols(c))
                Next c
            End If
        End If
    Next sr
    
    If dr = 0 Then
        MsgBox "No today's data found.", vbExclamation
        Exit Sub
    End If
    
    ' First Destination Row.
    Dim dfrrg As Range: Set dfrrg = drg.Resize(1).Offset(drg.Rows.Count)
    
    dfrrg.Resize(dr).Value = dData
   
    MsgBox "Today's data transferred.", vbInformation
   
End Sub

The following might be useful if the dates are strings.

Const DateFormat As String = "dd mmm yy"
Dim TodayString As String
' Either...
TodayString = Format(Date, DateFormat)
' ... or...
TodayString = Application.Text(Date, DateFormat) ' not English locale
' ... and there is only one If statement:
If CStr(sData(sr, CriteriaColumn)) = TodayString Then

The prevent copying... block might also need modifying.