Macro not looping through all files in folder

C

chard

New Member
Joined
Feb 17, 2023
Messages
5
Office Version
  1. 365
Platform
  1. Windows
Hi all,

I know there are solutions for this but I just need help incorporating them into my code. The code runs 1 time and does not loop because I have 2 directories open, so the Dir() "loses context". If someone could help me include a solution in my code I would be eternally grateful. Here is a link from stack overflow but I am very new to code so I can't really decipher it: Loop Through two different directories using VBA.

Below is the code I currently have:


VBA Code: 
Sub HiNiRate()

Application.ScreenUpdating = False
    Dim wkbDest As Workbook
    Dim wkbText As Workbook
    Dim wsDest As Worksheet
    Dim FinalDest As Workbook
    Dim wsFinal As Worksheet
    Dim i As Integer
    Dim j As Variant
    Dim RightSheet As String
    Dim Channel As String
    Dim SheetExt As String
    Dim LastRowA As Long
    Dim LastRowE As Long
    Dim LastRowK As Long
   
  
   
   
   
    Const LoadingDir As String = "C:\Users\CharlesMorton\Documents\Coin Cell Loading Measurements\"
    Const TextDir As String = "C:\Users\CharlesMorton\Documents\Rate Data\HiNi\"
    ChDir TextDir
    SheetExt = Dir("*.xl*")
    TextExt = Dir("*.txt*")
    i = 1
    Do While TextExt <> ""
        Set wkbText = Workbooks.Open(TextDir & TextExt)
        Set FinalDest = Workbooks.Open(TextDir & SheetExt)
        Set wsFinal = FinalDest.Worksheets(1)
       
        LastRowA = FinalDest.Worksheets(1).Cells(wsFinal.Rows.Count, "A").End(xlUp).Offset(1).Row
        LastRowE = FinalDest.Worksheets(1).Cells(wsFinal.Rows.Count, "E").End(xlUp).End(xlUp).End(xlUp).Offset(1).Row
        LastRowK = FinalDest.Worksheets(1).Cells(wsFinal.Rows.Count, "E").End(xlUp).End(xlUp).End(xlUp).Offset(2).Row
       
       
            With wkbText
            Dim TextName As String
            Dim Label As String
            TextName = .Sheets(1).Range("B1").Value
            Label = Mid(TextName, 1, (Len(TextName) - 6))
            Channel = Right(TextName, 5)
            CellNumber = Left(Channel, 1)
            Pnum = InStr(1, TextName, "(")
            SampleNum = Mid(TextName, Pnum, 6)
            RightSheet = LoadingDir & "*" & SampleNum & "-" & CellNumber & ".xls"
            RightSheetName = Dir(RightSheet)
           
           
            Set wkbDest = Workbooks.Open(LoadingDir & RightSheetName)
            wkbDest.Worksheets(2).Range("A1:F35").Value = .Sheets(1).Range("A1:F35").Value
           
            .Close savechanges:=False
           
           
           
           
            wsFinal.Range("E" & LastRowE & ":" & "K" & LastRowK).Value = wkbDest.Worksheets(1).Range("U54:AA55").Value
           
           
            wkbDest.Close savechanges:=True
           
   
           
   
   
            If Int(j) Then
                wsFinal.Range("A" & LastRowA).Value = Label
                wsFinal.Range("P2:AB11").Select
                Selection.Copy
                wsFinal.Range("A" & LastRowA + 10).Select
                wsFinal.Paste
            End If
   
   
   
       
   
   
        End With
   
        i = i + 1
        TextExt = Dir()
       
       
   
   
   
   
   
    Loop
   
   
   
   
End Sub
 
Last edited by a moderator:

Excel Facts

Spell Check in Excel
Press F7 to start spell check in Excel. Be careful, by default, Excel does not check Capitalized Werds (whoops)
Sort by date Sort by votes
You actually have 3 concurrent Dir function calls, Dir(RightSheet) being the 3rd. One solution is to do the first 2 Dir loops separately and put the file names in 2 Collections or arrays and then loop through the Collections or arrays instead of looping with the Dir function.

I've modified your code to use Collections, but this is untested. Also, the code will crash at Set FinalDest = Workbooks.Open(TextDir & wbkColl(i)) if the number of files matching "*.xl*" in TextDir is less than the number of files matching "*.txt*" in the same folder.

VBA Code: 
Sub HiNiRate()

    Dim wkbDest As Workbook
    Dim wkbText As Workbook
    Dim wsDest As Worksheet
    Dim FinalDest As Workbook
    Dim wsFinal As Worksheet
    Dim i As Integer
    Dim j As Variant
    Dim RightSheet As String
    Dim Channel As String
    Dim SheetExt As String
    Dim LastRowA As Long
    Dim LastRowE As Long
    Dim LastRowK As Long
      
    Const LoadingDir As String = "C:\Users\CharlesMorton\Documents\Coin Cell Loading Measurements\"
    Const TextDir As String = "C:\Users\CharlesMorton\Documents\Rate Data\HiNi\"
    
    Dim txtColl As Collection, wbkColl As Collection
    Dim file As String
    
    Set txtColl = New Collection
    Set wbkColl = New Collection
    
    file = Dir(TextDir & "*.xl*")
    While file <> vbNullString
        wbkColl.Add file
        file = Dir
    Wend
   
    file = Dir(TextDir & "*.txt*")
    While file <> vbNullString
        txtColl.Add file
        file = Dir
    Wend
    
    Application.ScreenUpdating = False
    
    For i = 1 To txtColl.Count
    
        Set wkbText = Workbooks.Open(TextDir & txtColl(i))
        Set FinalDest = Workbooks.Open(TextDir & wbkColl(i))
        Set wsFinal = FinalDest.Worksheets(1)
       
        LastRowA = FinalDest.Worksheets(1).Cells(wsFinal.Rows.Count, "A").End(xlUp).Offset(1).Row
        LastRowE = FinalDest.Worksheets(1).Cells(wsFinal.Rows.Count, "E").End(xlUp).End(xlUp).End(xlUp).Offset(1).Row
        LastRowK = FinalDest.Worksheets(1).Cells(wsFinal.Rows.Count, "E").End(xlUp).End(xlUp).End(xlUp).Offset(2).Row
       
        With wkbText
        
            Dim TextName As String
            Dim Label As String
            TextName = .Sheets(1).Range("B1").Value
            Label = Mid(TextName, 1, (Len(TextName) - 6))
            Channel = Right(TextName, 5)
            CellNumber = Left(Channel, 1)
            Pnum = InStr(1, TextName, "(")
            SampleNum = Mid(TextName, Pnum, 6)
            RightSheet = LoadingDir & "*" & SampleNum & "-" & CellNumber & ".xls"
            RightSheetName = Dir(RightSheet)
           
            Set wkbDest = Workbooks.Open(LoadingDir & RightSheetName)
            wkbDest.Worksheets(2).Range("A1:F35").Value = .Sheets(1).Range("A1:F35").Value
           
            .Close savechanges:=False
            
            wsFinal.Range("E" & LastRowE & ":" & "K" & LastRowK).Value = wkbDest.Worksheets(1).Range("U54:AA55").Value
           
            wkbDest.Close savechanges:=True
   
            If Int(j) Then
                wsFinal.Range("A" & LastRowA).Value = Label
                wsFinal.Range("P2:AB11").Select
                Selection.Copy
                wsFinal.Range("A" & LastRowA + 10).Select
                wsFinal.Paste
            End If
   
        End With
   
    Next
   
    Application.ScreenUpdating = True
   
End Sub

 
Upvote 1
Solution
John_w said:
You actually have 3 concurrent Dir function calls, Dir(RightSheet) being the 3rd. One solution is to do the first 2 Dir loops separately and put the file names in 2 Collections or arrays and then loop through the Collections or arrays instead of looping with the Dir function.

I've modified your code to use Collections, but this is untested. Also, the code will crash at Set FinalDest = Workbooks.Open(TextDir & wbkColl(i)) if the number of files matching "*.xl*" in TextDir is less than the number of files matching "*.txt*" in the same folder.

VBA Code: 
Sub HiNiRate()

    Dim wkbDest As Workbook
    Dim wkbText As Workbook
    Dim wsDest As Worksheet
    Dim FinalDest As Workbook
    Dim wsFinal As Worksheet
    Dim i As Integer
    Dim j As Variant
    Dim RightSheet As String
    Dim Channel As String
    Dim SheetExt As String
    Dim LastRowA As Long
    Dim LastRowE As Long
    Dim LastRowK As Long
     
    Const LoadingDir As String = "C:\Users\CharlesMorton\Documents\Coin Cell Loading Measurements\"
    Const TextDir As String = "C:\Users\CharlesMorton\Documents\Rate Data\HiNi\"
   
    Dim txtColl As Collection, wbkColl As Collection
    Dim file As String
   
    Set txtColl = New Collection
    Set wbkColl = New Collection
   
    file = Dir(TextDir & "*.xl*")
    While file <> vbNullString
        wbkColl.Add file
        file = Dir
    Wend
  
    file = Dir(TextDir & "*.txt*")
    While file <> vbNullString
        txtColl.Add file
        file = Dir
    Wend
   
    Application.ScreenUpdating = False
   
    For i = 1 To txtColl.Count
   
        Set wkbText = Workbooks.Open(TextDir & txtColl(i))
        Set FinalDest = Workbooks.Open(TextDir & wbkColl(i))
        Set wsFinal = FinalDest.Worksheets(1)
      
        LastRowA = FinalDest.Worksheets(1).Cells(wsFinal.Rows.Count, "A").End(xlUp).Offset(1).Row
        LastRowE = FinalDest.Worksheets(1).Cells(wsFinal.Rows.Count, "E").End(xlUp).End(xlUp).End(xlUp).Offset(1).Row
        LastRowK = FinalDest.Worksheets(1).Cells(wsFinal.Rows.Count, "E").End(xlUp).End(xlUp).End(xlUp).Offset(2).Row
      
        With wkbText
       
            Dim TextName As String
            Dim Label As String
            TextName = .Sheets(1).Range("B1").Value
            Label = Mid(TextName, 1, (Len(TextName) - 6))
            Channel = Right(TextName, 5)
            CellNumber = Left(Channel, 1)
            Pnum = InStr(1, TextName, "(")
            SampleNum = Mid(TextName, Pnum, 6)
            RightSheet = LoadingDir & "*" & SampleNum & "-" & CellNumber & ".xls"
            RightSheetName = Dir(RightSheet)
          
            Set wkbDest = Workbooks.Open(LoadingDir & RightSheetName)
            wkbDest.Worksheets(2).Range("A1:F35").Value = .Sheets(1).Range("A1:F35").Value
          
            .Close savechanges:=False
           
            wsFinal.Range("E" & LastRowE & ":" & "K" & LastRowK).Value = wkbDest.Worksheets(1).Range("U54:AA55").Value
          
            wkbDest.Close savechanges:=True
  
            If Int(j) Then
                wsFinal.Range("A" & LastRowA).Value = Label
                wsFinal.Range("P2:AB11").Select
                Selection.Copy
                wsFinal.Range("A" & LastRowA + 10).Select
                wsFinal.Paste
            End If
  
        End With
  
    Next
  
    Application.ScreenUpdating = True
  
End Sub
Click to expand...
John_w you are a king. Your code works basically perfectly with a few edits for my file paths. I have included the code below:

VBA Code: 
Sub Test()
    Dim wkbDest As Workbook
    Dim wkbText As Workbook
    Dim wsDest As Worksheet
    Dim FinalDest As Workbook
    Dim wsFinal As Worksheet
    Dim i As Integer
    Dim j As Variant
    Dim RightSheet As String
    Dim Channel As String
    Dim SheetExt As String
    Dim LastRowA As Long
    Dim LastRowE As Long
    Dim LastRowK As Long
      
    Const LoadingDir As String = "C:\Users\CharlesMorton\Documents\Coin Cell Loading Measurements\"
    Const TextDir As String = "C:\Users\CharlesMorton\Documents\Rate Data\HiNi\"
    
    Dim txtColl As Collection, wbkColl As Collection
    Dim file As String
    
    Set txtColl = New Collection
    Set wbkColl = New Collection
    
    file = Dir(LoadingDir & "*.xl*")
    While file <> vbNullString
        wbkColl.Add file
        file = Dir
    Wend
   
    file = Dir(TextDir & "*.txt*")
    While file <> vbNullString
        txtColl.Add file
        file = Dir
    Wend
    
    Application.ScreenUpdating = False
    j = 1
    For i = 1 To txtColl.Count
    
        Set wkbText = Workbooks.Open(TextDir & txtColl(i))
        Set FinalDest = Workbooks.Open(TextDir & "HiNi Rate" & ".xlsx")
        Set wsFinal = FinalDest.Worksheets(1)
       
        LastRowA = FinalDest.Worksheets(1).Cells(wsFinal.Rows.Count, "A").End(xlUp).Offset(1).Row
        LastRowE = FinalDest.Worksheets(1).Cells(wsFinal.Rows.Count, "E").End(xlUp).End(xlUp).End(xlUp).Offset(1).Row
        LastRowK = FinalDest.Worksheets(1).Cells(wsFinal.Rows.Count, "E").End(xlUp).End(xlUp).End(xlUp).Offset(2).Row
       
        With wkbText
            
            Dim TextName As String
            Dim Label As String
            TextName = .Sheets(1).Range("B1").Value
            Label = Mid(TextName, 1, (Len(TextName) - 11))
            Channel = Right(TextName, 5)
            CellNumber = Left(Channel, 1)
            Pnum = InStr(1, TextName, "(")
            SampleNum = Mid(TextName, Pnum, 6)
            RightSheet = LoadingDir & "*" & SampleNum & "-" & CellNumber & ".xls"
            RightSheetName = Dir(RightSheet)
            
            If Int(j / 4) Then
                wsFinal.Range("A" & LastRowA).Value = Label
                wsFinal.Range("P2:AB11").Select
                Selection.Copy
                wsFinal.Range("A" & LastRowA + 10).Select
                wsFinal.Paste
                j = 0
            End If
           
            Set wkbDest = Workbooks.Open(LoadingDir & RightSheetName)
            wkbDest.Worksheets(2).Range("A1:F35").Value = .Sheets(1).Range("A1:F35").Value
           
            .Close savechanges:=False
            
            wsFinal.Range("E" & LastRowE & ":" & "K" & LastRowK).Value = wkbDest.Worksheets(1).Range("U54:AA55").Value
           
            wkbDest.Close savechanges:=True
   
            
   
        End With
    j = j + 1
    Next
   
    Application.ScreenUpdating = True
    
End Sub
 
Upvote 0
Looking at your modified code, you don't use the wbkColl Collection, so all related lines can be deleted.
 
Upvote 0
You must log in or register to reply here.

Similar threads

T
  • Solved
Open all files in a folder and run macro
Replies
3
Views
610
Trebor76
T
C
  • Question Question
Extracting data from all files in the same folder
2
Replies
11
Views
1K
Joe4
Joe4
B
  • Solved
Code Works But Does Not Loop Through All Files
Replies
3
Views
583
Micron
M
A
  • Question Question
Automation of Copy and Merge Data in Column A and B of all files in a folder. Order of Data Differs
Replies
2
Views
660
ashish002
A
M
  • Solved
Looping through folder for latest file VBA
Replies
2
Views
1K
Mitchx
M

Forum statistics

Threads
1,223,243
Messages
6,170,967
Members
452,371
Latest member
Frana

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top