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)
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 works apart from the added complication of empty columns in both sheets that would be filled out manually with other data that isn't moved/ edited with during the macro execution. Wihtou the empty columns on each sheet, this works.
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
CodePudding user response：
Copy to Different Columns
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