Копирование данных с разными столбцами и именем листа из нескольких рабочих книг - VBA

Question

Копирование данных с разными столбцами и именем листа из нескольких рабочих книг - VBA

Привет, я пытался найти возможные решения для моего вопроса, но я не могу найти точный код, который мне нужен.

Мне нужно скопировать данные из двух разных книг с разными именами, а также из разных столбцов. Я использовал свой код при копировании данных из одной рабочей книги, но есть ошибка, говорящая

"Ошибка автоматизации".

Итак, что мне нужно сделать, это скопировать данные из имени листа Raw Data а также Arm Checklist на мой основной лист также называется 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

0

excel vba excel-vba merge hssfworkbook

Источник

user9459609 06 июл '18 в 03:47

2 ответа

Решение

Вот код, который я придумал, если у кого-то есть какие-либо идеи о том, как я могу выбрать свои книги как одну, потому что сейчас, когда я запускаю его, "Workbooks.Open(Filename:=Application.GetOpenFilename)" мне нужно выбрать дважды для меня, чтобы иметь возможность выбрать две рабочие книги, которые мне нужно объединить.

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

0

Источник

user9459609 06 июл '18 в 08:56

Другие вопросы по тегам excel vba excel-vba merge hssfworkbook

user8978777 13 июл '18 в 10:16 2018-07-13 10:16 · Accepted Answer · 2018-07-13 10:16

Эй, вот моя попытка решить вашу проблему:

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 сабвуфера, что не имеет особого смысла, так как вам всегда придется использовать оба сабвуфера. (bc 2-й подпункт будет вызываться так: вызовите conso2(otherworkfile(2)), поэтому вы не можете использовать 2-й подпункт без ввода.