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

Question

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

我收到此错误

  

下标超出范围（错误9）

我知道原因，因为它无法找到当前工作表以根据需要粘贴数据。

当前工作簿名为任务和当前工作表输出

这是编辑过的代码：

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和amp; 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