Excel VBA需求：粘贴外部数据后为每行批量填充指定日期

现有Excel VBA代码功能为：从外部工作簿的“Fuhrparksteuerung XLS Export”工作表复制数据到当前工作簿的“Übersicht”工作表，再将“Übersicht”的A4:M25区域复制到“Daten”工作表的最后一行下方。目前仅能在粘贴区域的首行A列填入当前工作簿A2单元格的日期，需修改代码实现将该日期填入所有粘贴行的A列对应单元格。

现有代码 #

Sub Schaltfläche1_Klicken()
Application.DisplayAlerts = False
Dim LastRow As Long
Dim i As Long
Dim mWB As Workbook 'This Workbook
Dim dWB As Workbook 'Data Workbook

'set the Main Workbook
Set mWB = ThisWorkbook


Dim filePath As String
filePath = Application.GetOpenFilename

Debug.Print filePath

'Set the Data Workbook
Set dWB = Workbooks.Open(filePath)

Dim dataSh As Worksheet
Set dataSh = dWB.Sheets("Fuhrparksteuerung XLS Export")

'copy the Data Table
dataSh.Range("A1").CurrentRegion.Copy

'Paste the Data Table
mWB.Sheets("Übersicht").Range("A1").PasteSpecial xlPasteAll

dWB.Close False
Application.DisplayAlerts = True



With ThisWorkbook.ActiveSheet
     LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
    End With
   
    
 LastRow = Sheets("Daten").Range("B65536").End(xlUp).Offset(1, 0).Row
    Range("A4:M25").Copy Destination:=Sheets("Daten").Range("B" & LastRow)
   Sheets("Daten").Range("A" & LastRow) = Range("A2").Value


End Sub

修改后的代码 #

Sub Schaltfläche1_Klicken()
    Application.DisplayAlerts = False
    Dim pasteStartRow As Long
    Dim pasteRowsCount As Long
    Dim mWB As Workbook '当前工作簿
    Dim dWB As Workbook '外部数据工作簿
    Dim dataSh As Worksheet
    Dim uebersichtSh As Worksheet
    Dim datenSh As Worksheet
    Dim filePath As String
    
    '绑定当前工作簿及目标工作表，避免依赖ActiveSheet
    Set mWB = ThisWorkbook
    Set uebersichtSh = mWB.Sheets("Übersicht")
    Set datenSh = mWB.Sheets("Daten")
    
    '选择外部文件，用户取消时直接退出
    filePath = Application.GetOpenFilename
    If filePath = "False" Then Exit Sub
    
    '从外部工作簿复制数据到Übersicht
    Set dWB = Workbooks.Open(filePath)
    Set dataSh = dWB.Sheets("Fuhrparksteuerung XLS Export")
    dataSh.Range("A1").CurrentRegion.Copy
    uebersichtSh.Range("A1").PasteSpecial xlPasteAll
    dWB.Close False
    Application.DisplayAlerts = True
    
    '计算Daten工作表的粘贴起始行
    pasteStartRow = datenSh.Cells(datenSh.Rows.Count, "B").End(xlUp).Offset(1, 0).Row
    '获取要复制的区域行数（A4:M25共22行）
    pasteRowsCount = uebersichtSh.Range("A4:M25").Rows.Count
    
    '复制数据到Daten工作表
    uebersichtSh.Range("A4:M25").Copy Destination:=datenSh.Range("B" & pasteStartRow)
    '批量填充日期到所有新行的A列
    datenSh.Range("A" & pasteStartRow & ":A" & pasteStartRow + pasteRowsCount - 1).Value = uebersichtSh.Range("A2").Value
End Sub

关键修改说明 #

• 明确工作表引用：定义uebersichtSh和datenSh变量绑定目标工作表，避免因工作表切换导致的错误。
• 批量填充逻辑：通过计算粘贴起始行和区域行数，一次性选中所有新粘贴行的A列单元格，统一赋值为A2的日期，替代原代码仅填充首行的逻辑。
• 增加容错处理：当用户取消选择外部文件时，直接退出子程序，避免后续执行报错。

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