Subscript out of range (Error 9): Loop through a folder of Excel files, copy cells and paste in the current worksheet

0
votes

I'm a beginner in VBA and have to work on some task to open a folder consists of scientific results in Excel files, select some cells based on a specific key from each Excel file and retrieve these data to the current workbook/worksheet in a sort of final table.

I'm getting this error

Subscript out of range (Error 9)

and I know the reason because it can't find the current worksheet to paste the data as required.

The current workbook named Task and current worksheet Output

Here's the edited code:

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

I guess the problem now is that this line returns Nothing, however it opens the right worksheet and both myPath & myFile are correct!

Set wb = Workbooks.Open(Filename:=myPath & myFile)
3
vbaexcel
So i would rather use Set current = ThisWorkbook. Also when you open the file then declare a variable for the worksheet like Dim sht as Worksheetand Set sht = wb.Worksheets(1) (Similiar for Target just with current. Also use wb and not activeWorkbook there.). Then every Cells, Range etc. should be objectified to make sure it references to the right workbook i.e sht.Cells(1,1).Value. What is erow = current.Worksheets("Output").Cells(85, 1) supposed to do? erow is declared as an integer but its a Range . And then you are using it as a Row? – Plagon
@UGP this line Set sht = wb.Worksheets(1) gives me " Object variable or with block variable not Set" – Weloo
You have to use Set after the wb has been opened. – Plagon
Yeah, i did and i got this error @UGP – Weloo
Add a message box before the line with error: MsgBox myPath & myFile Is the path of the file ok? – paul bica

3 Answers

0
votes

Try: 

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

As already mentioned erow = current.Worksheets("Output").Cells(85, 1) is just wrong and threw the subscript out of range error. You can get the value of the cell with .Value but then you would overwrite the values in the target sheet, so that only the last entry will be displayed.

0
votes

The code would to be like this. It is more easy to accumulate your data to array vR(). And in your current sheet to get it.

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
0
votes

So, here's the working code: it does retrieve data to the current worksheet, hope it helps anybody in the future.

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