复制到不同的列

Sub TransferToday()
    
    Const ColumnTitlesList As String = "Name,Product,Quantity,Date"
    Const CriteriaColumnTitle As String = "Date" ' need not be in the titles
    
    Dim Today As Date: Today = Date ' TODAY() in excel
    
    Dim ColumnTitles() As String: ColumnTitles = Split(ColumnTitlesList, ",")
    Dim cUpper As Long: cUpper = UBound(ColumnTitles)
    
    Dim c As Long ' Column Indexes Counter
    
    ' Write the source data to an array.
    
    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 ' table
    Dim shrg As Range: Set shrg = srg.Rows(1) ' header row
    Dim srCount As Long: srCount = srg.Rows.Count
    Dim sData() As Variant: sData = srg.Value
    
    ' Determine the source column indexes.
    
    ' Criteria Column
    Dim sccIndex As Long
    sccIndex = Application.Match(CriteriaColumnTitle, shrg, 0)
    
    ' Copy Columns
    Dim scIndexes() As Long: ReDim scIndexes(0 To cUpper)
    For c = 0 To cUpper
        scIndexes(c) = Application.Match(ColumnTitles(c), shrg, 0)
    Next c
    
    ' Write today's source row data to arrays in a collection.
    
    ' This collection will hold...
    Dim sColl As Collection: Set sColl = New Collection
    ' ... as many of these arrays...
    Dim sArr As Variant: ReDim sArr(0 To cUpper)
    ' ... as there are records with today's date found.
    ' Note that no parentheses ('sArr()') are used to make it more readable
    ' (understandable) when the same variable is used as the control variable
    ' in the For Each...Next loop later in the code.
    
    Dim sr As Long ' Source Rows Counter

    For sr = 2 To srCount ' skip header row
        If IsDate(sData(sr, sccIndex)) Then
            If sData(sr, sccIndex) = Today Then
                For c = 0 To cUpper
                    sArr(c) = sData(sr, scIndexes(c))
                Next c
                sColl.Add sArr
            End If
        End If
    Next sr
    
    Erase sData ' data is in the collection ('sColl')
    
    Dim drCount As Long: drCount = sColl.Count
    If drCount = 0 Then
        MsgBox "No today's data found.", vbExclamation
        Exit Sub
    End If
    
    ' Write today's source data from the collection to arrays of an array.
    
     ' This AKA jagged array will hold...
    Dim dJag() As Variant: ReDim dJag(0 To cUpper)
    ' ... as many of these arrays...
    Dim dArr() As Variant: ReDim dArr(1 To drCount, 1 To 1)
    ' ... as there are columns to be copied.
    
    For c = 0 To cUpper
        dJag(c) = dArr
    Next c
     
    Dim dr As Long ' Destination Rows Counter
    
    For Each sArr In sColl
        dr = dr + 1
        For c = 0 To cUpper
            dJag(c)(dr, 1) = sArr(c)
        Next c
    Next sArr
    
    Set sColl = Nothing ' data is in the array of arrays ('dJag')
    
    ' Reference the destination range.
    
    Dim dwb As Workbook: Set dwb = ThisWorkbook ' Workbooks("Destination.xlsm")
    Dim dws As Worksheet: Set dws = dwb.Worksheets("New")
    Dim drg As Range: Set drg = dws.Range("A1").CurrentRegion ' table
    Dim dhrg As Range: Set dhrg = drg.Rows(1) ' header row
    ' This is the range the new data will be written to.
    Set drg = drg.Resize(drCount).Offset(drg.Rows.Count)
    
    ' Determine the destination column indexes.
    
    ' Paste Columns
    Dim dcIndexes() As Long: ReDim dcIndexes(0 To cUpper)
    For c = 0 To cUpper
        dcIndexes(c) = Application.Match(ColumnTitles(c), dhrg, 0)
    Next c
    
    ' Write the data from the arrays of the array to the destination columns.
    
    For c = 0 To cUpper
        drg.Columns(dcIndexes(c)).Value = dJag(c)
    Next c
    
    ' Inform.
    
    MsgBox "Today's data transferred.", vbInformation
   
End Sub