从多个工作簿复制具有不同列和 sheet 名称的数据 - VBA

Question

您好，我尝试为我的问题寻找可能的解决方案，但找不到我需要的确切代码。

我需要从两个不同的工作簿中复制数据，这些工作簿具有不同的工作sheet名称和不同的列。我在从单个工作簿复制数据时使用了我的代码，但出现

错误

"Automation error".

所以我需要做的是将sheet名称Raw Data和Arm Checklist中的数据复制到我的主要工作sheet也命名为Raw Data ].

我需要从 Raw Data 复制的列来自 A7:Q，而复制到 Arm Checklist 的列来自 C3:D,G,E,H:J,K,M:Q。此列中的数据需要合并到我的 MainWorkfile Raw Data

Sub SAMPLE()        
    Dim MainWorkfile As Workbook
    Dim OtherWorkfile As Workbook
    Dim OtherWorkfile2 As Workbook
    Dim TrackerSht As Worksheet
    Dim FilterSht As Worksheet
    Dim FilterSht2 As Worksheet

    Dim lRow As Long, lRw As Long

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

    ' set workbook object
    Set MainWorkfile = ActiveWorkbook

    ' set the worksheet object
    Set TrackerSht = MainWorkfile.Sheets("Raw Data")
    With TrackerSht
        lRow = .Cells(.Rows.Count, "A").End(xlUp).Row ' last row with data in column "C"
        .Range("A7:S7" & lRow).ClearContents
    End With


    Application.AskToUpdateLinks = False

    ' set the 2nd workbook object
    Set OtherWorkfile = Workbooks.Open(Filename:=Application.GetOpenFilename)

    ' set the 2nd worksheet object
    Set FilterSht = OtherWorkfile.Sheets("Raw Data")

    With FilterSht
        If .FilterMode Or .AutoFilterMode Then .AutoFilterMode = False
        lRw = .Cells(.Rows.Count, "A").End(xlUp).Row ' last row with data in column "C"

        .Range("A7:Q" & lRw).Copy ' copy your range
    End With

    ' paste
    TrackerSht.Range("A7:Q" & lRow).PasteSpecial Paste:=xlPasteValues, _
                    Operation:=xlNone, SkipBlanks:=False, Transpose:=False

    OtherWorkfile.Close

    Set OtherWorkfile2 = Workbooks.Open(Filename:=Application.GetOpenFilename)

    ' set the 2nd worksheet object
    Set FilterSht2 = OtherWorkfile.Sheets("Arm Checklist")

    With FilterSht2
        If .FilterMode Or .AutoFilterMode Then .AutoFilterMode = False
        lRw = .Cells(.Rows.Count, "A").End(xlUp).Row ' last row with data in column "C"

        .Range("C3:D" & lRw).Copy ' copy your range
    End With

    ' paste
    TrackerSht.Range("A:B" & lRow).PasteSpecial Paste:=xlPasteValues, _
                    Operation:=xlNone, SkipBlanks:=False, Transpose:=False

    ' implement it for the rest of your columns...
    With FilterSht2
        If .FilterMode Or .AutoFilterMode Then .AutoFilterMode = False
        lRw = .Cells(.Rows.Count, "A").End(xlUp).Row ' last row with data in column "C"

        .Range("G3:G" & lRw).Copy ' copy your range
    End With

    ' paste
    TrackerSht.Range("C7:C" & lRow).PasteSpecial Paste:=xlPasteValues, _
                    Operation:=xlNone, SkipBlanks:=False, Transpose:=False


    With FilterSht2
        If .FilterMode Or .AutoFilterMode Then .AutoFilterMode = False
        lRw = .Cells(.Rows.Count, "A").End(xlUp).Row ' last row with data in column "C"

        .Range("E3:E" & lRw).Copy ' copy your range
    End With

    ' paste
    TrackerSht.Range("E7:E" & lRow).PasteSpecial Paste:=xlPasteValues, _
                    Operation:=xlNone, SkipBlanks:=False, Transpose:=False

    With FilterSht2
        If .FilterMode Or .AutoFilterMode Then .AutoFilterMode = False
        lRw = .Cells(.Rows.Count, "A").End(xlUp).Row ' last row with data in column "C"

        .Range("H3:J" & lRw).Copy ' copy your range
    End With

    ' paste
    TrackerSht.Range("F7:H" & lRow).PasteSpecial Paste:=xlPasteValues, _
                    Operation:=xlNone, SkipBlanks:=False, Transpose:=False

    OtherWorkfile2.Close



End Sub

Answer 1

这是我想出的代码，如果有人对我如何选择我的工作簿有任何其他想法，因为现在每当我运行它 "Workbooks.Open(Filename:=Application.GetOpenFilename)" 我需要选择两次才能 select 我需要合并的两个工作簿。

Sub conso1()

Dim MainWorkfile As Workbook
Dim OtherWorkfile2 As Workbook
Dim TrackerSht As Worksheet
Dim FilterSht2 As Worksheet

Dim lRow As Long, lRw As Long

Application.ScreenUpdating = False
Application.DisplayAlerts = False

' set workbook object
Set MainWorkfile = ActiveWorkbook

' set the worksheet object
Set TrackerSht = MainWorkfile.Sheets("Raw Data")
With TrackerSht
    lRow = .Cells(.Rows.Count, "A").End(xlUp).Row + 1 ' last row with data in column "C"
End With


Application.AskToUpdateLinks = False


On Error GoTo ErrHand:
'Set OtherWorkfile2 = Workbooks.Open(Filename:=Application.GetOpenFilename)
currentPath = Application.ActiveWorkbook.Path
Set OtherWorkfile2 = Workbooks.Open(currentPath & "\OtherWB2.xls")

' set the 2nd worksheet object
Set FilterSht2 = OtherWorkfile2.Sheets("Arm Checklist")


With FilterSht2
    If .FilterMode Or .AutoFilterMode Then .AutoFilterMode = False
    lRw = .Cells(.Rows.Count, "A").End(xlUp).Row ' last row with data in column "C"

    .Range("C3:D" & lRw).Copy ' copy your range
End With

' paste
TrackerSht.Range("A7:B" & lRow).PasteSpecial Paste:=xlPasteValues, _
                Operation:=xlNone, SkipBlanks:=False, Transpose:=False

' implement it for the rest of your columns...
With FilterSht2
    If .FilterMode Or .AutoFilterMode Then .AutoFilterMode = False
    lRw = .Cells(.Rows.Count, "A").End(xlUp).Row ' last row with data in column "C"

    .Range("G3:G" & lRw).Copy ' copy your range
End With

' paste
TrackerSht.Range("C7:C" & lRow).PasteSpecial Paste:=xlPasteValues, _
                Operation:=xlNone, SkipBlanks:=False, Transpose:=False


With FilterSht2
    If .FilterMode Or .AutoFilterMode Then .AutoFilterMode = False
    lRw = .Cells(.Rows.Count, "A").End(xlUp).Row ' last row with data in column "C"

    .Range("E3:E" & lRw).Copy ' copy your range
End With

' paste
TrackerSht.Range("E7:E" & lRow).PasteSpecial Paste:=xlPasteValues, _
                Operation:=xlNone, SkipBlanks:=False, Transpose:=False

With FilterSht2
    If .FilterMode Or .AutoFilterMode Then .AutoFilterMode = False
    lRw = .Cells(.Rows.Count, "A").End(xlUp).Row ' last row with data in column "C"

    .Range("H3:J" & lRw).Copy ' copy your range
End With

' paste
TrackerSht.Range("F7:H" & lRow).PasteSpecial Paste:=xlPasteValues, _
                Operation:=xlNone, SkipBlanks:=False, Transpose:=False


With FilterSht2
    If .FilterMode Or .AutoFilterMode Then .AutoFilterMode = False
    lRw = .Cells(.Rows.Count, "A").End(xlUp).Row ' last row with data in column "C"

    .Range("K3:K" & lRw).Copy ' copy your range
End With

' paste
TrackerSht.Range("L7:L" & lRow).PasteSpecial Paste:=xlPasteValues, _
                Operation:=xlNone, SkipBlanks:=False, Transpose:=False

With FilterSht2
    If .FilterMode Or .AutoFilterMode Then .AutoFilterMode = False
    lRw = .Cells(.Rows.Count, "A").End(xlUp).Row ' last row with data in column "C"

    .Range("M3:Q" & lRw).Copy ' copy your range
End With

' paste
TrackerSht.Range("M7:Q" & lRow).PasteSpecial Paste:=xlPasteValues, _
                Operation:=xlNone, SkipBlanks:=False, Transpose:=False

OtherWorkfile2.Close

ErrHand:

    If Err.Number = 1004 Then                    'could use 1004 here

        MsgBox "You Choose to Cancel"
        Err.clear
    Else
        Debug.Print Err.Description

    End If


Call conso2

End Sub


Sub conso2()

Dim MainWorkfile As Workbook
Dim OtherWorkfile As Workbook
Dim TrackerSht As Worksheet
Dim FilterSht As Worksheet

Dim lRow As Long, lRw As Long

Application.ScreenUpdating = False
Application.DisplayAlerts = False

' set workbook object
Set MainWorkfile = ActiveWorkbook

' set the worksheet object
Set TrackerSht = MainWorkfile.Sheets("Raw Data")
With TrackerSht
    lRow = .Cells(.Rows.Count, "A").End(xlUp).Row + 1 ' last row with data in column "C"
End With


Application.AskToUpdateLinks = False

On Error GoTo ErrHand:
'Set OtherWorkfile = Workbooks.Open(Filename:=Application.GetOpenFilename)
currentPath = Application.ActiveWorkbook.Path
Set OtherWorkfile = Workbooks.Open(currentPath & "\OtherWB.xls")
Set FilterSht = OtherWorkfile.Sheets("Raw Data")

With FilterSht
    If .FilterMode Or .AutoFilterMode Then .AutoFilterMode = False
    lRw = .Cells(.Rows.Count, "A").End(xlUp).Row ' last row with data in column "C"

    .Range("A7:Q" & lRw).Copy ' copy your range
End With

' paste
TrackerSht.Range("A" & lRow).PasteSpecial Paste:=xlPasteValues, _
                Operation:=xlNone, SkipBlanks:=False, Transpose:=False


OtherWorkfile.Close

ErrHand:

    If Err.Number = 1004 Then                    'could use 1004 here

        MsgBox "You Choose to Cancel"
        Err.clear
    Else
        Debug.Print Err.Description

    End If


End Sub

Answer 2

哟，这是我解决你问题的尝试：

Sub conso()

Dim MainWorkfile As Workbook
Dim myFiles As Variant
Dim fso As Scripting.FileSystemObject
Set fso = New Scripting.FileSystemObject
Dim OtherWorkfile(1 To 2) As Workbook
Dim CorrectionHandler(1 To 2) As Workbook
Dim TrackerSht As Worksheet
Dim FilterSht As Worksheet

Dim i As Integer

Dim lRow As Long, lRw As Long

Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.AskToUpdateLinks = False

' set workbook object
Set MainWorkfile = ThisWorkbook

' set the worksheet object
Set TrackerSht = MainWorkfile.Sheets("Raw Data")
With TrackerSht
    lRow = .Cells(.Rows.Count, "A").End(xlUp).Row + 1 ' last row with data in column "C"
End With

On Error GoTo ErrHand

TryAgain:
myFiles = Application.GetOpenFilename(MultiSelect:=True)

If UBound(OtherWorkfile) > 2 Then
    MsgBox "Too many WBs selected"
    GoTo TryAgain
End If

For i = LBound(myFiles) To UBound(myFiles)
    Set OtherWorkfile(i) = Workbooks.Open(myFiles(i))
Next i
'Set OtherWorkfile = Workbooks.Open(Filename:=Application.GetOpenFilename())
'currentPath = Application.ActiveWorkbook.Path
'Set OtherWorkfile = Workbooks.Open(currentPath & "\OtherWB2.xls")


On Error GoTo correction
GoTo jumper
correction:
Set CorrectionHandler(2) = OtherWorkfile(1)
Set CorrectionHandler(1) = OtherWorkfile(2)
Set OtherWorkfile(1) = CorrectionHandler(1)
Set OtherWorkfile(2) = CorrectionHandler(2)
On Error GoTo ErrHand
jumper:

' set the 2nd worksheet object
Set FilterSht = OtherWorkfile(1).Sheets("Arm Checklist")

On Error GoTo ErrHand

With FilterSht
    If .FilterMode Or .AutoFilterMode Then .AutoFilterMode = False
    lRw = .Cells(.Rows.Count, "A").End(xlUp).Row ' last row with data in column "C"

    .Range("C3:D" & lRw).Copy ' copy your range
End With

' paste
TrackerSht.Range("A7:B" & lRow).PasteSpecial Paste:=xlPasteValues, _
                Operation:=xlNone, SkipBlanks:=False, Transpose:=False

' implement it for the rest of your columns...
With FilterSht
    If .FilterMode Or .AutoFilterMode Then .AutoFilterMode = False
    lRw = .Cells(.Rows.Count, "A").End(xlUp).Row ' last row with data in column "C"

    .Range("G3:G" & lRw).Copy ' copy your range
End With

' paste
TrackerSht.Range("C7:C" & lRow).PasteSpecial Paste:=xlPasteValues, _
                Operation:=xlNone, SkipBlanks:=False, Transpose:=False


With FilterSht
    If .FilterMode Or .AutoFilterMode Then .AutoFilterMode = False
    lRw = .Cells(.Rows.Count, "A").End(xlUp).Row ' last row with data in column "C"

    .Range("E3:E" & lRw).Copy ' copy your range
End With

' paste
TrackerSht.Range("E7:E" & lRow).PasteSpecial Paste:=xlPasteValues, _
                Operation:=xlNone, SkipBlanks:=False, Transpose:=False

With FilterSht
    If .FilterMode Or .AutoFilterMode Then .AutoFilterMode = False
    lRw = .Cells(.Rows.Count, "A").End(xlUp).Row ' last row with data in column "C"

    .Range("H3:J" & lRw).Copy ' copy your range
End With

' paste
TrackerSht.Range("F7:H" & lRow).PasteSpecial Paste:=xlPasteValues, _
                Operation:=xlNone, SkipBlanks:=False, Transpose:=False


With FilterSht
    If .FilterMode Or .AutoFilterMode Then .AutoFilterMode = False
    lRw = .Cells(.Rows.Count, "A").End(xlUp).Row ' last row with data in column "C"

    .Range("K3:K" & lRw).Copy ' copy your range
End With

' paste
TrackerSht.Range("L7:L" & lRow).PasteSpecial Paste:=xlPasteValues, _
                Operation:=xlNone, SkipBlanks:=False, Transpose:=False

With FilterSht
    If .FilterMode Or .AutoFilterMode Then .AutoFilterMode = False
    lRw = .Cells(.Rows.Count, "A").End(xlUp).Row ' last row with data in column "C"

    .Range("M3:Q" & lRw).Copy ' copy your range
End With

' paste
TrackerSht.Range("M7:Q" & lRow).PasteSpecial Paste:=xlPasteValues, _
                Operation:=xlNone, SkipBlanks:=False, Transpose:=False

OtherWorkfile(1).Close
'----------------------------2nd Workbook-------------------------------------

With TrackerSht
    lRow = .Cells(.Rows.Count, "A").End(xlUp).Row + 1 ' last row with data in column "C"
End With


Application.AskToUpdateLinks = False

'Set OtherWorkfile = Workbooks.Open(Filename:=Application.GetOpenFilename)
'currentPath = Application.ActiveWorkbook.Path
'Set OtherWorkfile = Workbooks.Open(currentPath & "\OtherWB.xls")
Set FilterSht = OtherWorkfile(2).Sheets("Raw Data")

With FilterSht
    If .FilterMode Or .AutoFilterMode Then .AutoFilterMode = False
    lRw = .Cells(.Rows.Count, "A").End(xlUp).Row ' last row with data in column "C"

    .Range("A7:Q" & lRw).Copy ' copy your range
End With

' paste
TrackerSht.Range("A" & lRow).PasteSpecial Paste:=xlPasteValues, _
                Operation:=xlNone, SkipBlanks:=False, Transpose:=False

OtherWorkfile(2).Close

ErrHand:

    If Err.Number = 1004 Then                    'could use 1004 here

        MsgBox "You Choose to Cancel"
        Err.Clear
    Else
        Debug.Print Err.Description

    End If


Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.AskToUpdateLinks = True

End Sub

如您所见，现在一切都在 1 个子中。可以将它分成 2 个潜艇，这没有多大意义，因为您总是必须使用两个潜艇。（公元前第二个子会这样称呼：调用 conso2(otherworkfile(2)) 所以你不能使用第二个子 w/o inputvar.

从多个工作簿复制具有不同列和 sheet 名称的数据 - VBA

Copying data with different columns and sheet name from multiple workbooks - VBA

vba

excel

merge

hssfworkbook