Excel VBA跨工作表列复制追加及现有宏代码整合咨询

功能实现逻辑 #

• 执行Closed OB表清空操作前，自动提取该表B、D列的有效数据
• 将提取内容追加到Sheet2的A、B列已有数据的末尾，不会覆盖原有历史记录
• 采用批量赋值实现操作，运行效率远高于常规复制粘贴操作

新增追加代码段 #

以下是需要插入到原宏Range("A:J").ClearContents语句上方的代码：

' 追加Closed OB表B、D列到Sheet2的A、B列末尾
Dim wsSource As Worksheet, wsTarget As Worksheet
Dim sourceLastRow As Long, targetLastRow As Long
Set wsSource = ThisWorkbook.Sheets("Closed OB")
' 注意：如果你的目标表名称不是Sheet2，请修改下方引号内的名称
Set wsTarget = ThisWorkbook.Sheets("Sheet2")

' 分别获取源表和目标表的有效数据最后行号
sourceLastRow = wsSource.Cells(wsSource.Rows.Count, "B").End(xlUp).Row
targetLastRow = wsTarget.Cells(wsTarget.Rows.Count, "A").End(xlUp).Row + 1

' 仅当源表存在有效数据时执行追加操作，避免空行写入
If sourceLastRow >= 1 Then
    wsTarget.Range("A" & targetLastRow & ":A" & targetLastRow + sourceLastRow - 1).Value = wsSource.Range("B1:B" & sourceLastRow).Value
    wsTarget.Range("B" & targetLastRow & ":B" & targetLastRow + sourceLastRow - 1).Value = wsSource.Range("D1:D" & sourceLastRow).Value
End If

修改后的完整宏代码 #

Sub Get_Data_From_File()
    Dim FileToOpen As Variant
    Dim OpenBook As Workbook
    Dim sourceSheet As Worksheet
    Set sourceSheet = ActiveSheet
    
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Application.Calculation = xlCalculationManual
    
    Sheets("Closed OB").Visible = True
    Sheets("Temp Closed").Visible = True
    
    Sheets("Closed OB").Select
    '===== 新增追加数据到Sheet2的代码 开始 =====
    Dim wsSource As Worksheet, wsTarget As Worksheet
    Dim sourceLastRow As Long, targetLastRow As Long
    Set wsSource = ThisWorkbook.Sheets("Closed OB")
    ' 注意：如果你的目标表名称不是Sheet2，请修改下方引号内的名称
    Set wsTarget = ThisWorkbook.Sheets("Sheet2")

    ' 分别获取源表和目标表的有效数据最后行号
    sourceLastRow = wsSource.Cells(wsSource.Rows.Count, "B").End(xlUp).Row
    targetLastRow = wsTarget.Cells(wsTarget.Rows.Count, "A").End(xlUp).Row + 1

    ' 仅当源表存在有效数据时执行追加操作，避免空行写入
    If sourceLastRow >= 1 Then
        wsTarget.Range("A" & targetLastRow & ":A" & targetLastRow + sourceLastRow - 1).Value = wsSource.Range("B1:B" & sourceLastRow).Value
        wsTarget.Range("B" & targetLastRow & ":B" & targetLastRow + sourceLastRow - 1).Value = wsSource.Range("D1:D" & sourceLastRow).Value
    End If
    '===== 新增追加数据到Sheet2的代码 结束 =====
    Range("A:J").ClearContents
    
    FileToOpen = Application.GetOpenFilename(Title:="Browse for your File & Import Range", FileFilter:="Excel Files (*.xls*),*xls*")
    If FileToOpen <> False Then
        Set OpenBook = Application.Workbooks.Open(FileToOpen)
        OpenBook.Sheets(1).Range("A4:G1000").Copy
        ThisWorkbook.Worksheets(3).Range("A1:G1000").Value = OpenBook.Sheets(1).Range("A4:G1000").Value
        OpenBook.Sheets(1).Range("H4:H1000").Copy
        ThisWorkbook.Worksheets(3).Range("J1:J1000").Value = OpenBook.Sheets(1).Range("H4:H1000").Value
        OpenBook.Sheets(2).Range("A4:M1000").Copy
        ThisWorkbook.Worksheets(4).Range("A2:R998").Value = OpenBook.Sheets(2).Range("A4:M1000").Value
        OpenBook.Close False
    End If
    
    ThisWorkbook.Worksheets("Closed OB").Range("G1").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.TextToColumns Destination:=Range("G1"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=False, _
        Semicolon:=False, Comma:=False, Space:=True, Other:=False, FieldInfo _
        :=Array(Array(1, 1), Array(2, 1), Array(3, 1)), TrailingMinusNumbers:=True
    
    LastRow = Sheets(4).UsedRange.SpecialCells(xlCellTypeLastCell).Row
    
    Sheets("Temp Closed").Select
    With Range("D2:D" & LastRow)
        .NumberFormat = General
        .Value = .Value
    
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    End With
    
    Sheets("Closed OB").Visible = False
    Sheets("Temp Closed").Visible = False
    
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    Application.Calculation = xlCalculationAutomatic
    
    Call sourceSheet.Activate

End Sub

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