下标超出范围（错误9）：循环浏览Excel文件文件夹，复制单元格并粘贴到当前工作表中

Question

我是VBA的初学者，必须执行一些任务才能打开一个包含Excel文件中科学结果的文件夹，根据每个Excel文件中的特定键选择一些单元格，然后将这些数据检索到当前工作簿/工作表中。决赛桌。

我收到这个错误

下标超出范围（错误9）

我知道原因是因为它找不到当前的工作表来按要求粘贴数据。

当前工作簿名为Task和当前工作表Output

这是编辑后的代码：

Sub LoopAllExcelFilesInFolder()

  Dim wb As Workbook, current As Workbook
  Dim myPath As String
  Dim myFile As String
  Dim myExtension As String
  Dim FldrPicker As FileDialog
  Dim sht As Worksheet

  'set source workbook
  Set current = ThisWorkbook

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

'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 variable equal to opened workbook
      Set wb = Workbooks.Open(Filename:=myPath & myFile)

   'Ensure Workbook has opened before moving on to next line of code
      DoEvents

      Set sht = wb.Worksheets(1)

      ' create an array with the keys' names
      Dim arr(3) As String
      Dim element As Variant

      arr(0) = "aclr_utra1"
      arr(1) = "aclr_utra2"
      arr(2) = "aclr_eutra"

      ' get the last row in each worksheet
       Dim LastRow As Integer, i As Integer, erow As Integer
       LastRow = ActiveSheet.Range("J" & Rows.Count).End(xlUp).Row

      'create two nested loops to retrieve the results with each key
      For Each element In arr


      ' Retrieve and copy the matched results

        For i = 35 To LastRow
            If sht.Cells(i, 9).Value = CStr(element) Then


            sht.Cells(i, 6).Copy 'BW
            sht.Cells(i, 8).Copy 'Spec_symbol


       ' copy to the final sheet
        erow = current.Worksheets("Output").Cells(85, 1)

       ActiveSheet.Cells(erow, 1).Select
       ActiveSheet.Paste
       ActiveWorkbook.Save
       ActiveWorkbook.Close
       Application.CutCopyMode = False
        End If

Next i
Next element


  'Ensure Workbook has closed before moving on to next line of code
      DoEvents

    'Get next file name
      myFile = Dir
    Loop

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

End Sub

---

我想现在的问题是该行返回Nothing，但是它打开了正确的工作表，并且myPath和myFile都是正确的！

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

Answer 1

尝试：

Sub LoopAllExcelFilesInFolder()

  Dim wb As Workbook, current As Workbook
  Dim myPath As String
  Dim myFile As String
  Dim myExtension As String
  Dim FldrPicker As FileDialog
  Dim sht As Worksheet
  Dim crange As Range

  'set source workbook
  Set current = ThisWorkbook

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

'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 variable equal to opened workbook
      Set wb = Workbooks.Open(Filename:=myPath & myFile)

   'Ensure Workbook has opened before moving on to next line of code
      DoEvents

      Set sht = wb.Worksheets(1)

      ' create an array with the keys' names
      Dim arr(3) As String
      Dim element As Variant

      arr(0) = "aclr_utra1"
      arr(1) = "aclr_utra2"
      arr(2) = "aclr_eutra"

      ' get the last row in each worksheet
       Dim LastRow As Integer, i As Integer, erow As Integer
       LastRow = sht.Range("J" & Rows.Count).End(xlUp).Row

      'create two nested loops to retrieve the results with each key
      For Each element In arr


      ' Retrieve and copy the matched results

        For i = 35 To LastRow
            If sht.Cells(i, 9).Value = CStr(element) Then

            ' copy to the final sheet
            erow = current.Worksheets("Output").Cells(85, 1).Value
            Set crange = Union(sht.Cells(i, 6), sht.Cells(i, 8))
            crange.Copy current.Worksheets(1).Cells(erow, 1)
            Application.CutCopyMode = False
        End If
        Next i
        Next element

        wb.Close
  'Ensure Workbook has closed before moving on to next line of code
      DoEvents

    'Get next file name
      myFile = Dir
    Loop

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

End Sub

如前所述， erow = current.Worksheets("Output").Cells(85, 1)就是错误的，下标超出了范围错误。 您可以使用.Value获取单元格的值，但随后您将覆盖目标工作表中的值，以便仅显示最后一个条目。

Answer 2

该代码将是这样的。 将数据累积到数组vR（）更容易。 并在您当前的工作表中获取它。

Sub LoopAllExcelFilesInFolder()

    Dim wb As Workbook, current As Workbook
    Dim myPath As String
    Dim myFile As String
    Dim myExtension As String
    Dim FldrPicker As FileDialog
    Dim sht As Worksheet
    Dim curWs As Worksheet, rngT As Range
    Dim vR() As Variant, n As Long

      'set source workbook
    Set current = ThisWorkbook
    Set curWs = current.Sheets("Output")
    Set rngT = curWs.Range("a85")

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

    '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)

    Dim arr(3) As String
    Dim element As Variant

    arr(0) = "aclr_utra1"
    arr(1) = "aclr_utra2"
    arr(2) = "aclr_eutra"

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

   'Ensure Workbook has opened before moving on to next line of code
     ' DoEvents

      Set sht = wb.Worksheets(1)
      Dim LastRow As Long
      LastRow = sht.Range("J" & Rows.Count).End(xlUp).Row

      'create two nested loops to retrieve the results with each key
        For Each element In arr
          ' Retrieve and copy the matched results
            For i = 35 To LastRow
                If sht.Cells(i, 9).Value = CStr(element) Then
                    n = n + 2
                    ReDim Preserve vR(1 To n)
                    vR(n - 1) = sht.Cells(i, 6)
                    vR(n) = sht.Cells(i, 8)
                    'sht.Cells(i, 6).Copy 'BW
                    'sht.Cells(i, 8).Copy 'Spec_symbol
                   ' copy to the final sheet
                    'erow = current.Worksheets("Output").Cells(85, 1)

                   'ActiveSheet.Cells(erow, 1).Select
                   'ActiveSheet.Paste
                   'ActiveWorkbook.Save
                   'ActiveWorkbook.Close
                   'Application.CutCopyMode = False
                End If

            Next i
        Next element
        wb.Close (0)

  'Ensure Workbook has closed before moving on to next line of code
      'DoEvents

    'Get next file name
      myFile = Dir
    Loop
    If n > 0 Then
        rngT.Resize(n) = WorksheetFunction.Transpose(vR)
    End If
ResetSettings:
  'Reset Macro Optimization Settings
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True

End Sub

Answer 3

因此，这是工作代码：它确实将数据检索到当前工作表，希望将来对任何人有帮助。

Option Explicit
Sub LoopAllExcelFilesInFolder()

Dim wbk As Workbook
Dim Filename As String
Dim Path As String
Dim saywhat
Dim zItem
Dim arr(3) As String
Dim element As Variant
Dim LastRow As Long
Dim BW As Long
Dim RowCount As Integer
arr(0) = "aclr_utra1"
arr(1) = "aclr_utra2"
arr(2) = "aclr_eutra"


Path = ThisWorkbook.Path                        'set a default path

'**********************************************
'DISPLAY FOLDER SELECTION BOX..                   'display folder picker
'**********************************************
With Application.FileDialog(msoFileDialogFolderPicker)          'use shortcut
saywhat = "Select the source folder for the source datafiles.." 'define browser text
.Title = saywhat                                'show heading message for THIS dialog box
.AllowMultiSelect = False                       'allow only one file to be selected
.InitialFileName = Path                         'set default source folder
zItem = .Show                                   'display the file selection dialog

.InitialFileName = ""                           'clear and reset search folder\file filter

If zItem = 0 Then Exit Sub                      'User cancelled; 0=no folder chosen

Path = .SelectedItems(1)                        'selected folder
End With                                        'end of shortcut

If Right(Path, 1) <> "\" Then                   'check for required last \ in path
Path = Path & "\"                               'add required last \ if missing
End If                                          'end of test fro required last \ char

Debug.Print Path
Filename = Dir(Path & "*.xlsm")

Debug.Print Filename

Do While Len(Filename) > 0
Set wbk = Workbooks.Open(Filename:=Path & Filename)
      Dim i As Integer
      LastRow = ActiveSheet.Range("J" & Rows.Count).End(xlUp).Row

      'create two nested loops to retrieve the results with each key
        For Each element In arr
          ' Retrieve and copy the matched results
            For i = 35 To LastRow
                If ActiveSheet.Cells(i, 9).Value = CStr(element) Then

                    Debug.Print CStr(element)
                    Debug.Print ActiveSheet.Cells(i, 7).Value
                    BW = ActiveSheet.Cells(i, 7).Select 'BW
                    Range(Selection, Selection.End(xlDown)).Select
                    Range(Selection, Selection.End(xlToRight)).Select
                    Selection.Copy
                    Windows("Task.xlsm").Activate
                    Range("A1").Select
                    RowCount = Worksheets("Output").Range("A1").CurrentRegion.Rows.Count
                    With Worksheets("Output").Range("A1").Offset(RowCount, 0) = BW
                    End With
                    ActiveWorkbook.Save
                    End If

            Next i
        Next element

wbk.Close True
Filename = Dir

Loop

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

End Sub