Question

我已经掌握了全部知识，非常感谢您提供的一些调试帮助。

我已经尝试过制作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。我不确定自己在做什么错，但是我无法克服这个问题。

对于同一张纸中的一堆不同范围是否执行此操作，我还应该提到这些是合并的单元格，但是范围内的多个合并的单元格-假设是问题所在。

Answer 1

尝试一下...

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

Answer 2

我是一个新手，所以我自己并没有拿出这段代码。我也很高兴听到任何建议，以便我可以学习和开发更多可用/更好的代码。我要说的是我的关注点是处理时间。我在打开并复制/粘贴其值的3个工作簿上进行了测试，但是最终我可能会在1000年代的不同文件夹中执行此任务（我将进入并重新运行两次，并将myrow初始化更改为上次打开一个-有意手动操作，而不是使用x1down方法，这样就不会有人或多或少地弄乱它，或者不正确地使用它，或者一遍又一遍地选择同一文件夹来复制值）。再说一次，它在.PasteSpecial之后还没有xlPasteValues（对我来说是必需的，可能不需要全部。）

谢谢Stack Overflow社区！！！特别感谢您帮助我达到这一目标的海报！

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

有没有一种方法可以循环浏览多个工作簿以将范围复制到一个活动的工作簿中？

2 个答案: