Excel VBA需求：将工作表日期批量填充至主表对应行

现状与需求 #

• 现有功能：同一工作簿内多张工作表，已实现定位每张表中以Green起始的A列区域，复制粘贴至主工作表Main构建数据库，功能正常。
• 待实现功能：每张工作表的Cells(3,3)单元格含日期值，需将该日期填充到主表Main的B列，且填充行数与对应粘贴的A列区域行数一致。

现有VBA代码 #

Sub FindRangeHistory()

'// in MainDB workbook for each trade sheet, copy and paste specific range into 'Main' sheet

    Dim fnd As String, faddr As String
    Dim rng As Range, foundCell As Range
    Dim ws As Worksheet


    Dim ws_count As Integer, i As Integer
    ws_count = ThisWorkbook.Worksheets.Count
    
For i = 1 To ws_count
    
    With ThisWorkbook
    
    'initialize main sheet and keyword search
        Set ws = .Worksheets("Main")
        fnd = "New Life"

    'Search for keyword in sheet
        With .Worksheets(i)
            Set foundCell = .Cells.Find(What:=fnd, after:=.Cells.SpecialCells(xlCellTypeLastCell), _
                                        LookIn:=xlFormulas, LookAt:=xlWhole, _
                                        SearchOrder:=xlByRows, SearchDirection:=xlNext)
            'Test to see if anything was found
            If Not foundCell Is Nothing Then
                faddr = foundCell.Address
                Set rng = .Range(foundCell, foundCell.End(xlDown))
                Do
                    Set rng = Union(rng, .Range(foundCell, foundCell.End(xlDown)).Resize(, 7))
                    Set foundCell = .Cells.FindNext(after:=foundCell)
                Loop Until foundCell.Address = faddr

                Set rng = rng.Offset(1, 0)
                rng.Copy
                ws.Cells(Rows.Count, "C").End(xlUp).PasteSpecial Paste:=xlPasteValues


                Worksheets(i).Cells(3, 3).Copy
                ws.Cells(Rows.Count, "B").End(xlUp).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
           End If
        End With
    End With
Next i
    
End Sub

修改后的代码 #

Sub FindRangeHistory()

'// in MainDB workbook for each trade sheet, copy and paste specific range into 'Main' sheet

    Dim fnd As String, faddr As String
    Dim rng As Range, foundCell As Range
    Dim wsMain As Worksheet
    Dim wsCurrent As Worksheet
    Dim targetRow As Long
    Dim dateValue As Variant
    Dim rngRows As Integer

    Dim ws_count As Integer, i As Integer
    ws_count = ThisWorkbook.Worksheets.Count
    
    '提前指定主表，避免循环内重复赋值
    Set wsMain = ThisWorkbook.Worksheets("Main")
    fnd = "New Life"
    
For i = 1 To ws_count
    Set wsCurrent = ThisWorkbook.Worksheets(i)
    '跳过主表本身，避免重复处理
    If wsCurrent.Name <> wsMain.Name Then
        With wsCurrent
            Set foundCell = .Cells.Find(What:=fnd, after:=.Cells.SpecialCells(xlCellTypeLastCell), _
                                        LookIn:=xlFormulas, LookAt:=xlWhole, _
                                        SearchOrder:=xlByRows, SearchDirection:=xlNext)
            'Test to see if anything was found
            If Not foundCell Is Nothing Then
                faddr = foundCell.Address
                Set rng = .Range(foundCell, foundCell.End(xlDown))
                Do
                    Set rng = Union(rng, .Range(foundCell, foundCell.End(xlDown)).Resize(, 7))
                    Set foundCell = .Cells.FindNext(after:=foundCell)
                Loop Until foundCell.Address = faddr

                Set rng = rng.Offset(1, 0)
                rngRows = rng.Rows.Count '获取当前复制区域的行数
                targetRow = wsMain.Cells(Rows.Count, "C").End(xlUp).Row + 1 '主表C列的目标起始行
                
                '复制数据到主表C列开始的区域
                rng.Copy
                wsMain.Cells(targetRow, "C").PasteSpecial Paste:=xlPasteValues
                
                '获取当前工作表的日期值
                dateValue = .Cells(3, 3).Value
                '填充日期到主表B列对应行数的区域
                wsMain.Range(wsMain.Cells(targetRow, "B"), wsMain.Cells(targetRow + rngRows - 1, "B")).Value = dateValue
                '保留日期格式（如果需要）
                wsMain.Range(wsMain.Cells(targetRow, "B"), wsMain.Cells(targetRow + rngRows - 1, "B")).NumberFormat = .Cells(3, 3).NumberFormat
           End If
        End With
    End If
Next i
    
    '清除剪贴板，避免弹窗提示
    Application.CutCopyMode = False
End Sub

关键修改点 #

• 新增wsMain、wsCurrent变量区分主表和当前处理的工作表，避免循环内重复查找主表，同时跳过主表本身的处理
• 获取复制区域的行数rngRows，定位主表的目标起始行targetRow
• 直接批量赋值日期到B列对应行数的区域，替代原单单元格粘贴操作，同时保留原日期格式
• 添加Application.CutCopyMode = False清除剪贴板，避免后续操作的弹窗干扰

内容的提问来源于stack exchange，提问作者coolintake