Есть ли способ перебрать несколько рабочих книг для копирования диапазонов в одну активную рабочую книгу? - PullRequest
Новая
       4

Есть ли способ перебрать несколько рабочих книг для копирования диапазонов в одну активную рабочую книгу?

0 голосов
/ 02 апреля 2019

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

Я уже пытался просто сделать wb.sheet.range.value = wb1.sheet.range.value

'''vba

Dim wb As Workbook
Dim wb1 As Workbook
Dim myPath As String
Dim myFile As String
Dim myExtension As String
Dim FldrPicker As FileDialog
Dim myRow As Integer
Dim aSMOnly As Range


'Initialize myRow variable
myRow = 2
Set wb1 = ActiveWorkbook

With wb1
    .Sheets.Add(After:=.Sheets(.Sheets.Count)).Name = "Assembly"

'theres a bunch of other sheets added
End With
  Do While myFile <> ""
    Set wb = Workbooks.Open(Filename:=myPath & myFile)

    ' Copy data from source
    Set aSMOnly = wb.Sheets("Assembly Daily Tracker").Range("B5:J6")

'''

, поэтому последняя показанная строка выдает runtime 91 error. Я не уверен, что я делаю неправильно, но я не могу пройти через это.

Делает ли это для группы различных диапазонов в пределах одного листа, я должен также упомянуть, что это объединенные ячейки, но несколько объединенных ячеек в пределах диапазона - при условии, что это проблема.

Ответы [ 2 ]

0 голосов
/ 03 апреля 2019

Я довольно новичок и не придумал блоков этого кода самостоятельно.Я также более чем рад услышать любой совет, который поможет мне изучить и разработать более удобный / лучший код.Я скажу, что мое беспокойство - время обработки.Я выполнил тест на 3 книгах, открывая и копируя / вставляя их значения, но в конечном итоге я могу выполнять эту задачу на тысячах и в разных папках (я просто дважды захожу и запускаю ее повторно и изменяю инициализацию myrow на последнее открытоеодин - преднамеренно вручную, вместо использования подхода x1down, чтобы никто не более или менее не вмешивался в него, или неправильно использовал его, или дублировал значения, выбирая одну и ту же папку снова и снова).Опять же, у него нет xlPasteValues ​​после .PasteSpecial (необходим для меня, может быть, не нужен для всех).

Спасибо, сообщество переполнения стека !!!Особенно спасибо за плакаты, которые помогли мне добраться до этой точки! 

Sub DataExtractMultiFiles()
    'PURPOSE: To loop through all Excel files in a user specified folder and perform a set task on them

    Dim wb As Workbook
    Dim wb1 As Workbook
    Dim myPath As String
    Dim myFile As String
    Dim myExtension As String
    Dim FldrPicker As FileDialog
    Dim myRow As Integer
    Dim aSMOnly As Range
    Dim team1a As Range
    Dim team2a As Range
    Dim team3a As Range
    Dim team4a As Range
    Dim team5a As Range
    Dim team6a As Range
    Dim team7a As Range
    Dim teamEa As Range
    Dim firstShiftASM As Range
    Dim team1b As Range
    Dim team2b As Range
    Dim team3b As Range
    Dim team4b As Range
    Dim team5b As Range
    Dim team6b As Range
    Dim team7b As Range
    Dim teamEb As Range
    Dim secondShiftASM As Range
    Dim team1c As Range
    Dim teamEc As Range
    Dim thirdShiftASM As Range

    'Initialize myRow variable
    myRow = 2
    Set wb1 = ActiveWorkbook

    With wb1
        .Sheets.Add(After:=.Sheets(.Sheets.Count)).Name = "Assembly"
        .Sheets.Add(After:=.Sheets(.Sheets.Count)).Name = "Team 1a"
        .Sheets.Add(After:=.Sheets(.Sheets.Count)).Name = "Team 2a"
        .Sheets.Add(After:=.Sheets(.Sheets.Count)).Name = "Team 3a"
        .Sheets.Add(After:=.Sheets(.Sheets.Count)).Name = "Team 4a"
        .Sheets.Add(After:=.Sheets(.Sheets.Count)).Name = "Team 5a"
        .Sheets.Add(After:=.Sheets(.Sheets.Count)).Name = "Team 6a"
        .Sheets.Add(After:=.Sheets(.Sheets.Count)).Name = "Team 7a"
        .Sheets.Add(After:=.Sheets(.Sheets.Count)).Name = "Team Ea"
        .Sheets.Add(After:=.Sheets(.Sheets.Count)).Name = "1st Assembly"
        .Sheets.Add(After:=.Sheets(.Sheets.Count)).Name = "Team 1b"
        .Sheets.Add(After:=.Sheets(.Sheets.Count)).Name = "Team 2b"
        .Sheets.Add(After:=.Sheets(.Sheets.Count)).Name = "Team 3b"
        .Sheets.Add(After:=.Sheets(.Sheets.Count)).Name = "Team 4b"
        .Sheets.Add(After:=.Sheets(.Sheets.Count)).Name = "Team 5b"
        .Sheets.Add(After:=.Sheets(.Sheets.Count)).Name = "Team 6b"
        .Sheets.Add(After:=.Sheets(.Sheets.Count)).Name = "Team 7b"
        .Sheets.Add(After:=.Sheets(.Sheets.Count)).Name = "Team Eb"
        .Sheets.Add(After:=.Sheets(.Sheets.Count)).Name = "2nd Assembly"
        .Sheets.Add(After:=.Sheets(.Sheets.Count)).Name = "Team 1c"
        .Sheets.Add(After:=.Sheets(.Sheets.Count)).Name = "Team Ec"
        .Sheets.Add(After:=.Sheets(.Sheets.Count)).Name = "3rd Assembly"
    End With

    'Optimize Macro Speed
      Application.ScreenUpdating = False
      Application.EnableEvents = False
      Application.Calculation = xlCalculationManual
      Application.AskToUpdateLinks = False
      Application.DisplayAlerts = False

    'Retrieve Target Folder Path From User
      Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)

        With FldrPicker
          .Title = "Select A Target Folder"
          .AllowMultiSelect = False
            If .Show <> -1 Then GoTo NextCode
            myPath = .SelectedItems(1) & "\"
        End With

    'In Case of Cancel
    NextCode:
      myPath = myPath
      If myPath = "" Then GoTo ResetSettings

    'Target File Extension (must include wildcard "*")
      myExtension = "*.xls*"

    'Target Path with Ending Extention
      myFile = Dir(myPath & myExtension)

    'Loop through each Excel file in folder
      Do While myFile <> ""
        Set wb = Workbooks.Open(Filename:=myPath & myFile)

        ' Copy data from source

            'Values for Total Summary
        Set aSMOnly = wb.Sheets("Assembly Daily Tracker").Range("B5:J6")
        aSMOnly.Copy
        wb1.Sheets("Assembly").Range("B" + CStr(myRow) + ":J" +         CStr(myRow)).PasteSpecial
        wb1.Sheets("Assembly").Cells(myRow, "A").Value = wb.FullName

            'Values for First Shift
        Set team1a = wb.Sheets("Assembly Daily Tracker").Range("B7:J7")
        team1a.Copy
        wb1.Sheets("Team 1a").Range("B" + CStr(myRow) + ":J" +         CStr(myRow)).PasteSpecial
        wb1.Sheets("Team 1a").Cells(myRow, "A").Value = wb.FullName

Set team2a = wb.Sheets("Assembly Daily Tracker").Range("B8:J8")
team2a.Copy
wb1.Sheets("Team 2a").Range("B" + CStr(myRow) + ":J" + CStr(myRow)).PasteSpecial
wb1.Sheets("Team 2a").Cells(myRow, "A").Value = wb.FullName

Set team3a = wb.Sheets("Assembly Daily Tracker").Range("B9:J9")
team3a.Copy
wb1.Sheets("Team 3a").Range("B" + CStr(myRow) + ":J" + CStr(myRow)).PasteSpecial
wb1.Sheets("Team 3a").Cells(myRow, "A").Value = wb.FullName

Set team4a = wb.Sheets("Assembly Daily Tracker").Range("B10:J10")
team4a.Copy
wb1.Sheets("Team 4a").Range("B" + CStr(myRow) + ":J" + CStr(myRow)).PasteSpecial
wb1.Sheets("Team 4a").Cells(myRow, "A").Value = wb.FullName

Set team5a = wb.Sheets("Assembly Daily Tracker").Range("B11:J11")
team5a.Copy
wb1.Sheets("Team 5a").Range("B" + CStr(myRow) + ":J" + CStr(myRow)).PasteSpecial
wb1.Sheets("Team 5a").Cells(myRow, "A").Value = wb.FullName

Set team6a = wb.Sheets("Assembly Daily Tracker").Range("B12:J12")
team6a.Copy
wb1.Sheets("Team 6a").Range("B" + CStr(myRow) + ":J" + CStr(myRow)).PasteSpecial
wb1.Sheets("Team 6a").Cells(myRow, "A").Value = wb.FullName

Set team7a = wb.Sheets("Assembly Daily Tracker").Range("B13:J13")
team7a.Copy
wb1.Sheets("Team 7a").Range("B" + CStr(myRow) + ":J" + CStr(myRow)).PasteSpecial
wb1.Sheets("Team 7a").Cells(myRow, "A").Value = wb.FullName

Set teamEa = wb.Sheets("Assembly Daily Tracker").Range("B14:J14")
teamEa.Copy
wb1.Sheets("Team Ea").Range("B" + CStr(myRow) + ":J" + CStr(myRow)).PasteSpecial
wb1.Sheets("Team Ea").Cells(myRow, "A").Value = wb.FullName

Set firstShiftASM = wb.Sheets("Assembly Daily Tracker").Range("B15:J15")
firstShiftASM.Copy
wb1.Sheets("1st Assembly").Range("B" + CStr(myRow) + ":J" + CStr(myRow)).PasteSpecial
wb1.Sheets("1st Assembly").Cells(myRow, "A").Value = wb.FullName


    'Values for Second Shift
Set team1b = wb.Sheets("Assembly Daily Tracker").Range("B16:J16")
team1b.Copy
wb1.Sheets("Team 1b").Range("B" + CStr(myRow) + ":J" + CStr(myRow)).PasteSpecial
wb1.Sheets("Team 1b").Cells(myRow, "A").Value = wb.FullName

Set team2b = wb.Sheets("Assembly Daily Tracker").Range("B17:J17")
team2b.Copy
wb1.Sheets("Team 2b").Range("B" + CStr(myRow) + ":J" + CStr(myRow)).PasteSpecial
wb1.Sheets("Team 2b").Cells(myRow, "A").Value = wb.FullName

Set team3b = wb.Sheets("Assembly Daily Tracker").Range("B18:J18")
team3b.Copy
wb1.Sheets("Team 3b").Range("B" + CStr(myRow) + ":J" + CStr(myRow)).PasteSpecial
wb1.Sheets("Team 3b").Cells(myRow, "A").Value = wb.FullName

Set team4b = wb.Sheets("Assembly Daily Tracker").Range("B19:J19")
team4b.Copy
wb1.Sheets("Team 4b").Range("B" + CStr(myRow) + ":J" + CStr(myRow)).PasteSpecial
wb1.Sheets("Team 4b").Cells(myRow, "A").Value = wb.FullName

Set team5b = wb.Sheets("Assembly Daily Tracker").Range("B20:J20")
team5b.Copy
wb1.Sheets("Team 5b").Range("B" + CStr(myRow) + ":J" + CStr(myRow)).PasteSpecial
wb1.Sheets("Team 5b").Cells(myRow, "A").Value = wb.FullName

Set team6b = wb.Sheets("Assembly Daily Tracker").Range("B21:J21")
team6b.Copy
wb1.Sheets("Team 6b").Range("B" + CStr(myRow) + ":J" + CStr(myRow)).PasteSpecial
wb1.Sheets("Team 6b").Cells(myRow, "A").Value = wb.FullName

Set team7b = wb.Sheets("Assembly Daily Tracker").Range("B22:J22")
team7b.Copy
wb1.Sheets("Team 7b").Range("B" + CStr(myRow) + ":J" + CStr(myRow)).PasteSpecial
wb1.Sheets("Team 7b").Cells(myRow, "A").Value = wb.FullName

Set teamEb = wb.Sheets("Assembly Daily Tracker").Range("B23:J23")
teamEb.Copy
wb1.Sheets("Team Eb").Range("B" + CStr(myRow) + ":J" + CStr(myRow)).PasteSpecial
wb1.Sheets("Team Eb").Cells(myRow, "A").Value = wb.FullName

Set secondShiftASM = wb.Sheets("Assembly Daily Tracker").Range("B24:J24")
secondShiftASM.Copy
wb1.Sheets("2nd Assembly").Range("B" + CStr(myRow) + ":J" + CStr(myRow)).PasteSpecial
wb1.Sheets("2nd Assembly").Cells(myRow, "A").Value = wb.FullName


    'Values for Third Shift
Set team1c = wb.Sheets("Assembly Daily Tracker").Range("B25:J25")
team1c.Copy
wb1.Sheets("Team 1c").Range("B" + CStr(myRow) + ":J" + CStr(myRow)).PasteSpecial
wb1.Sheets("Team 1c").Cells(myRow, "A").Value = wb.FullName

Set teamEc = wb.Sheets("Assembly Daily Tracker").Range("B26:J26")
teamEc.Copy
wb1.Sheets("Team Ec").Range("B" + CStr(myRow) + ":J" + CStr(myRow)).PasteSpecial
wb1.Sheets("Team Ec").Cells(myRow, "A").Value = wb.FullName

Set thirdShiftASM = wb.Sheets("Assembly Daily Tracker").Range("B27:J27")
thirdShiftASM.Copy
wb1.Sheets("3rd Assembly").Range("B" + CStr(myRow) + ":J" + CStr(myRow)).PasteSpecial
wb1.Sheets("3rd Assembly").Cells(myRow, "A").Value = wb.FullName

myRow = myRow + 1

'Close Workbook
  wb.Close SaveChanges:=False

'Get next file name
  myFile = Dir
     Loop

    ResetSettings:
      'Reset Macro Optimization Settings
        Application.EnableEvents = True
        Application.Calculation = xlCalculationAutomatic
        Application.ScreenUpdating = True
        Application.DisplayAlerts = True
        Application.AskToUpdateLinks = True

    End Sub
0 голосов
/ 03 апреля 2019

Попробуй это ... 

Option Explicit
Sub main()

Dim wb As Workbook
Dim wb1 As Workbook
Dim myPath As String
Dim myFile As String
Dim myExtension As String
Dim FldrPicker As FileDialog
Dim aSMOnly As Range
Dim myRow As Integer

Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)

    With FldrPicker
      .Title = "Select Folder"
      .AllowMultiSelect = False
        If .Show <> -1 Then GoTo NextCode
        myPath = .SelectedItems(1) & "\"
    End With

NextCode:
myPath = myPath
myExtension = "*.xlsx"
myFile = Dir(myPath & myExtension)

myRow = 2
Set wb1 = ActiveWorkbook

With wb1
    .Sheets.Add(After:=.Sheets(.Sheets.Count)).Name = "Assembly"
End With

Do While myFile <> ""

Set wb = Workbooks.Open(Filename:=myPath & myFile)

Set aSMOnly = wb.Sheets("Assembly Daily Tracker").Range("B5:J6")
aSMOnly.Copy
wb1.Sheets(1).Range("D2:E5").PasteSpecial

wb.Close SaveChanges:=True

myFile = Dir
Loop

End Sub
...