如何將特定范圍從一個作業表復制到另一個作業簿中的另一個作業表

我有兩個作業簿：Source.xlsm, sheet= Orig 和 Destination.xlsm, sheet=New

我正在嘗試以特定方式在這些作業表之間移動資料：運行宏之前的兩個作業表示例（列排序是故意的）

在原始表中，單元格 F1 以以下格式存盤今天的日期：dd mmm yy

我的目標是僅從 Orig 中獲取具有今天日期的行，并將所有這些行按特定順序放置到新作業表的末尾。這樣在運行宏之后，New 看起來像：

任何關于如何進步的建議都會很棒

我有以下代碼片段開始形成解決方案，全部保存在 Source.xlsm 中。這正確選擇了 Orig 的底部兩行，因為它們在 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

下一步是以正確的列順序將這些選定的行附加到 New。

uj5u.com熱心網友回復：

將資料復制到不同的列

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

如果日期是字串，則以下內容可能很有用。

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

防止復制...塊也可能需要修改。

標籤：擅长vba

上一篇：Excel-在表格中查找值

下一篇：是否有任何特定功能可以找到比較兩張紙的唯一TP編號？