我有兩個作業簿：Source.xlsm, sheet= Orig 和 Destination.xlsm, sheet=New
我正在嘗試以特定方式在這些作業表之間移動資料：運行宏之前的兩個作業表示例（列排序是故意的）
我的目標是僅從 Orig 中獲取具有今天日期的行，并將所有這些行按特定順序放置到新作業表的末尾。這樣在運行宏之后，New 看起來像：
任何關于如何進步的建議都會很棒
我有以下代碼片段開始形成解決方案，全部保存在 Source.xlsm 中。除了在兩個作業表中增加的空列的復雜性之外，這將使用在宏執行期間未移動/編輯的其他資料手動填寫。對于每張紙上的空列，這是可行的。
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
uj5u.com熱心網友回復：
復制到不同的列
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
轉載請註明出處，本文鏈接：https://www.uj5u.com/yidong/529614.html
標籤：擅长vba