VBA - DO while and filename contains*

3

30136353

Board Regular
Joined
Aug 14, 2019
Messages
105
Hi Guys,

I have the below code, which looks through a folder for files and copies the data into my open workbook. I need the code to look for filenames only containing a string of ABC, and if the filename contains anything else, then X (The sheet to copy) would be 1 to 2 (Instead of 3 to 3)... Anyhelp?

Thanks

VBA Code: 
    Do While MyFile <> ""
Set wkbSource = Workbooks.Open(Filename:=MyFolder & "\" & MyFile)
For x = 3 To 3
If WorksheetFunction.CountA(Sheets(x).Cells) <> 0 Then
With Sheets(x)
LastRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
End With
With Surveys
Sheets(x).UsedRange.Copy .Cells(.Rows.Count, "B").End(xlUp).Offset(2, 0)
.Cells(.Rows.Count, "A").End(xlUp).Offset(2, 0).Resize(LastRow) = wkbSource.Name
    End With

    End If
Next x
MyFile = Dir
wkbSource.Close False
    Loop
 

Excel Facts

How to find 2nd largest value in a column?
MAX finds the largest value. =LARGE(A:A,2) will find the second largest. =SMALL(A:A,3) will find the third smallest
Sort by date Sort by votes
what about this?
VBA Code: 
Do While MyFile <> ""
Set wkbSource = Workbooks.Open(Filename:=MyFolder & "\" & MyFile)
If InStr(MyFile, "ABC") Then
For x = 3 To 3
    If WorksheetFunction.CountA(Sheets(x).Cells) <> 0 Then
    With Sheets(x)
    LastRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    End With
    With Surveys
    Sheets(x).UsedRange.Copy .Cells(.Rows.Count, "B").End(xlUp).Offset(2, 0)
    .Cells(.Rows.Count, "A").End(xlUp).Offset(2, 0).Resize(LastRow) = wkbSource.Name
    End With
    End If
Next x
Else
For x = 1 To 2
    If WorksheetFunction.CountA(Sheets(x).Cells) <> 0 Then
    With Sheets(x)
    LastRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    End With
    With Surveys
    Sheets(x).UsedRange.Copy .Cells(.Rows.Count, "B").End(xlUp).Offset(2, 0)
    .Cells(.Rows.Count, "A").End(xlUp).Offset(2, 0).Resize(LastRow) = wkbSource.Name
    End With
    End If
Next x
End If
MyFile = Dir
wkbSource.Close False
    Loop
 
Upvote 0
yinkajewole said:
what about this?
VBA Code: 
Do While MyFile <> ""
Set wkbSource = Workbooks.Open(Filename:=MyFolder & "\" & MyFile)
If InStr(MyFile, "ABC") Then
For x = 3 To 3
    If WorksheetFunction.CountA(Sheets(x).Cells) <> 0 Then
    With Sheets(x)
    LastRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    End With
    With Surveys
    Sheets(x).UsedRange.Copy .Cells(.Rows.Count, "B").End(xlUp).Offset(2, 0)
    .Cells(.Rows.Count, "A").End(xlUp).Offset(2, 0).Resize(LastRow) = wkbSource.Name
    End With
    End If
Next x
Else
For x = 1 To 2
    If WorksheetFunction.CountA(Sheets(x).Cells) <> 0 Then
    With Sheets(x)
    LastRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    End With
    With Surveys
    Sheets(x).UsedRange.Copy .Cells(.Rows.Count, "B").End(xlUp).Offset(2, 0)
    .Cells(.Rows.Count, "A").End(xlUp).Offset(2, 0).Resize(LastRow) = wkbSource.Name
    End With
    End If
Next x
End If
MyFile = Dir
wkbSource.Close False
    Loop
Click to expand...
Thanks, worked a charm! I was close to getting that previously but couldn't figure out the Next X and loop part... Much appreciated. Would you know how to have this currecnt code loop through all sub folders within the chosen folder?

VBA Code: 
   Sub TrialOwnWritten()

   Application.ScreenUpdating = False
Application.DisplayStatusBar = False
   Application.DisplayAlerts = False

    Sheets("Setup").Activate
Dim MyFolder As String, MyFile As String, wkbSource As Workbook, Surveys As Worksheet, FNCs As Worksheet, x As Long, LastRow As Long
Set Surveys = ActiveWorkbook.Sheets("Survey Returns")
Set FNCs = ActiveWorkbook.Sheets("FNC's")
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Select the latest ILC folder from your desktop"
.Show
.AllowMultiSelect = False
If .SelectedItems.Count = 0 Then
MsgBox "You did not select a folder."
Exit Sub
End If
MyFolder = .SelectedItems(1) & "\"
End With
    MyFile = Dir(MyFolder)

Do While MyFile <> ""
Set wkbSource = Workbooks.Open(Filename:=MyFolder & "\" & MyFile)
If InStr(MyFile, "SURV") Then
For x = 3 To 3
If WorksheetFunction.CountA(Sheets(x).Cells) <> 0 Then
With Sheets(x)
LastRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
End With
With Surveys
Sheets(x).UsedRange.Copy .Cells(.Rows.Count, "B").End(xlUp).Offset(2, 0)
.Cells(.Rows.Count, "A").End(xlUp).Offset(2, 0).Resize(LastRow) = wkbSource.Name
End With
End If
Next x
Else
For x = 1 To 2
If WorksheetFunction.CountA(Sheets(x).Cells) <> 0 Then
With Sheets(x)
LastRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
End With
With FNCs
Sheets(x).UsedRange.Copy .Cells(.Rows.Count, "B").End(xlUp).Offset(2, 0)
.Cells(.Rows.Count, "A").End(xlUp).Offset(2, 0).Resize(LastRow) = wkbSource.Name
End With
End If
Next x
End If
MyFile = Dir
wkbSource.Close False
    Loop
 
Upvote 0
give this a try
VBA Code: 
Sub TrialOwnWritten()
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Select the latest ILC folder from your desktop"
.Show
.AllowMultiSelect = False
If .SelectedItems.Count = 0 Then
MsgBox "You did not select a folder."
Exit Sub
End If
MyFolder = .SelectedItems(1) & "\"
End With
LoopAllSubFolders MyFolder
End Sub
Sub LoopAllSubFolders(ByVal folderPath As String)
Dim fileName As String
Dim fullFilePath As String
Dim numFolders As Long
Dim folders() As String
Dim i As Long
   Application.ScreenUpdating = False
Application.DisplayStatusBar = False
   Application.DisplayAlerts = False
    Sheets("Setup").Activate
Set Surveys = ActiveWorkbook.Sheets("Survey Returns")
Set FNCs = ActiveWorkbook.Sheets("FNC's")
If Right(folderPath, 1) <> "\" Then folderPath = folderPath & "\"
fileName = Dir(folderPath & "*.*", vbDirectory)
While Len(fileName) <> 0
    If Left(fileName, 1) <> "." Then
         fullFilePath = folderPath & fileName
         If (GetAttr(fullFilePath) And vbDirectory) = vbDirectory Then
            ReDim Preserve folders(0 To numFolders) As String
            folders(numFolders) = fullFilePath
            numFolders = numFolders + 1
        Else
           Set wkbSource = Workbooks.Open(fileName:=folderPath & fileName)
            If InStr(fileName, "SURV") Then
            For x = 3 To 3
            If WorksheetFunction.CountA(Sheets(x).Cells) <> 0 Then
            With Sheets(x)
            LastRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
            End With
            With Surveys
            Sheets(x).UsedRange.Copy .Cells(.Rows.Count, "B").End(xlUp).Offset(2, 0)
            .Cells(.Rows.Count, "A").End(xlUp).Offset(2, 0).Resize(LastRow) = wkbSource.Name
            End With
            End If
            Next x
            Else
            For x = 1 To 2
            If WorksheetFunction.CountA(Sheets(x).Cells) <> 0 Then
            With Sheets(x)
            LastRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
            End With
            With FNCs
            Sheets(x).UsedRange.Copy .Cells(.Rows.Count, "B").End(xlUp).Offset(2, 0)
            .Cells(.Rows.Count, "A").End(xlUp).Offset(2, 0).Resize(LastRow) = wkbSource.Name
            End With
            End If
            Next x
            End If
            wkbSource.Close False
        End If
    End If
    fileName = Dir()
Wend
For i = 0 To numFolders - 1
    LoopAllSubFolders folders(i)
Next i
End Sub
 
Upvote 0
yinkajewole said:
give this a try
VBA Code: 
Sub TrialOwnWritten()
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Select the latest ILC folder from your desktop"
.Show
.AllowMultiSelect = False
If .SelectedItems.Count = 0 Then
MsgBox "You did not select a folder."
Exit Sub
End If
MyFolder = .SelectedItems(1) & "\"
End With
LoopAllSubFolders MyFolder
End Sub
Sub LoopAllSubFolders(ByVal folderPath As String)
Dim fileName As String
Dim fullFilePath As String
Dim numFolders As Long
Dim folders() As String
Dim i As Long
   Application.ScreenUpdating = False
Application.DisplayStatusBar = False
   Application.DisplayAlerts = False
    Sheets("Setup").Activate
Set Surveys = ActiveWorkbook.Sheets("Survey Returns")
Set FNCs = ActiveWorkbook.Sheets("FNC's")
If Right(folderPath, 1) <> "\" Then folderPath = folderPath & "\"
fileName = Dir(folderPath & "*.*", vbDirectory)
While Len(fileName) <> 0
    If Left(fileName, 1) <> "." Then
         fullFilePath = folderPath & fileName
         If (GetAttr(fullFilePath) And vbDirectory) = vbDirectory Then
            ReDim Preserve folders(0 To numFolders) As String
            folders(numFolders) = fullFilePath
            numFolders = numFolders + 1
        Else
           Set wkbSource = Workbooks.Open(fileName:=folderPath & fileName)
            If InStr(fileName, "SURV") Then
            For x = 3 To 3
            If WorksheetFunction.CountA(Sheets(x).Cells) <> 0 Then
            With Sheets(x)
            LastRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
            End With
            With Surveys
            Sheets(x).UsedRange.Copy .Cells(.Rows.Count, "B").End(xlUp).Offset(2, 0)
            .Cells(.Rows.Count, "A").End(xlUp).Offset(2, 0).Resize(LastRow) = wkbSource.Name
            End With
            End If
            Next x
            Else
            For x = 1 To 2
            If WorksheetFunction.CountA(Sheets(x).Cells) <> 0 Then
            With Sheets(x)
            LastRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
            End With
            With FNCs
            Sheets(x).UsedRange.Copy .Cells(.Rows.Count, "B").End(xlUp).Offset(2, 0)
            .Cells(.Rows.Count, "A").End(xlUp).Offset(2, 0).Resize(LastRow) = wkbSource.Name
            End With
            End If
            Next x
            End If
            wkbSource.Close False
        End If
    End If
    fileName = Dir()
Wend
For i = 0 To numFolders - 1
    LoopAllSubFolders folders(i)
Next i
End Sub
Click to expand...
Hi there,

I got an error that something in the main folder is file format invalid, In the main folders sometimes there are other files within there like saved emails, word dcouments etc, so not just sub folders? The error message was on line:

Thanks for the help

VBA Code: 
           Set wkbSource = Workbooks.Open(fileName:=folderPath & fileName)
 
Upvote 0
30136353 said:
Hi there,

I got an error that something in the main folder is file format invalid, In the main folders sometimes there are other files within there like saved emails, word dcouments etc, so not just sub folders? The error message was on line:

Thanks for the help

VBA Code: 
           Set wkbSource = Workbooks.Open(fileName:=folderPath & fileName)
Click to expand...
It also doesn't seem to pick up the files with "Surv" in them, although it works if I take them out of the sub folders...

VBA Code: 
Sub newsheet()

With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Select the latest ILC folder from your desktop"
.Show
.AllowMultiSelect = False
If .SelectedItems.Count = 0 Then
MsgBox "You did not select a folder."
Exit Sub
End If
MyFolder = .SelectedItems(1) & "\"
End With
LoopAllSubFolders MyFolder
End Sub
Sub LoopAllSubFolders(ByVal folderPath As String)
Dim fileName As String
Dim fullFilePath As String
Dim numFolders As Long
Dim folders() As String
Dim i As Long

   Application.ScreenUpdating = False
Application.DisplayStatusBar = False
Application.DisplayAlerts = False

Sheets("Setup").Activate

Set Surveys = ActiveWorkbook.Sheets("Survey Returns")
Set FNCs = ActiveWorkbook.Sheets("FNC's")
If Right(folderPath, 1) <> "\" Then folderPath = folderPath & "\"
fileName = Dir(folderPath & "*.*", vbDirectory)
While Len(fileName) <> 0
If Left(fileName, 1) <> "." Then
fullFilePath = folderPath & fileName
If (GetAttr(fullFilePath) And vbDirectory) = vbDirectory Then
ReDim Preserve folders(0 To numFolders) As String
folders(numFolders) = fullFilePath
numFolders = numFolders + 1
Else
Set wkbSource = Workbooks.Open(fileName:=folderPath & fileName)
If InStr(fileName, "Surv") Then
For x = 3 To 3
If WorksheetFunction.CountA(Sheets(x).Cells) <> 0 Then
With Sheets(x)
LastRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
End With
With Surveys
Sheets(x).UsedRange.Copy .Cells(.Rows.Count, "B").End(xlUp).Offset(2, 0)
.Cells(.Rows.Count, "A").End(xlUp).Offset(2, 0).Resize(LastRow) = wkbSource.Name
End With
End If
Next x

Else

If InStr(fileName, "EH") Then
For x = 1 To 2
If WorksheetFunction.CountA(Sheets(x).Cells) <> 0 Then
With Sheets(x)
LastRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
End With
With FNCs
Sheets(x).UsedRange.Copy .Cells(.Rows.Count, "B").End(xlUp).Offset(2, 0)
.Cells(.Rows.Count, "A").End(xlUp).Offset(2, 0).Resize(LastRow) = wkbSource.Name
End With
End If
Next x
Else

End If
End If
wkbSource.Close False
End If
End If
fileName = Dir()
Wend
For i = 0 To numFolders - 1
LoopAllSubFolders folders(i)
Next i
 
Upvote 0
yinkajewole said:
you've altered the code
Click to expand...
Hi, yes I altered it slightly so the it will only take files with either "Surv" or "EH" within the name. When I select a folder with only files in it, it extracts the files exactly as I need. It only has an issue when there are sub folders...
 
Upvote 0
try this and give me a feedback
VBA Code: 
Sub TrialOwnWritten()
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Select the latest ILC folder from your desktop"
.Show
.AllowMultiSelect = False
If .SelectedItems.Count = 0 Then
MsgBox "You did not select a folder."
Exit Sub
End If
MyFolder = .SelectedItems(1) & "\"
End With
LoopAllSubFolders MyFolder
End Sub
Sub LoopAllSubFolders(ByVal folderPath As String)
Dim fileName As String
Dim fullFilePath As String
Dim numFolders As Long
Dim folders() As String
Dim i As Long
   Application.ScreenUpdating = False
Application.DisplayStatusBar = False
   Application.DisplayAlerts = False
    Sheets("Setup").Activate
Set Surveys = ActiveWorkbook.Sheets("Survey Returns")
Set FNCs = ActiveWorkbook.Sheets("FNC's")
If Right(folderPath, 1) <> "\" Then folderPath = folderPath & "\"
fileName = Dir(folderPath & "*.*", vbDirectory)
While Len(fileName) <> 0
    If Left(fileName, 1) <> "." Then
         fullFilePath = folderPath & fileName
         If (GetAttr(fullFilePath) And vbDirectory) = vbDirectory Then
            ReDim Preserve folders(0 To numFolders) As String
            folders(numFolders) = fullFilePath
            numFolders = numFolders + 1
        Else
           If Right(fileName, 5) = ".xlsx" Then
           Set wkbSource = Workbooks.Open(fileName:=folderPath & fileName)
            If InStr(1, fileName, "SURV", vbTextCompare) Then
            For x = 3 To 3
            If WorksheetFunction.CountA(Sheets(x).Cells) <> 0 Then
            With Sheets(x)
            LastRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
            End With
            With Surveys
            Sheets(x).UsedRange.Copy .Cells(.Rows.Count, "B").End(xlUp).Offset(2, 0)
            .Cells(.Rows.Count, "A").End(xlUp).Offset(2, 0).Resize(LastRow) = wkbSource.Name
            End With
            End If
            Next x
            ElseIf InStr(1, fileName, "EH", vbTextCompare) Then
            For x = 1 To 2
            If WorksheetFunction.CountA(Sheets(x).Cells) <> 0 Then
            With Sheets(x)
            LastRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
            End With
            With FNCs
            Sheets(x).UsedRange.Copy .Cells(.Rows.Count, "B").End(xlUp).Offset(2, 0)
            .Cells(.Rows.Count, "A").End(xlUp).Offset(2, 0).Resize(LastRow) = wkbSource.Name
            End With
            End If
            Next x
            End If
            wkbSource.Close False
        End If
        End If
    End If
    fileName = Dir()
Wend
For i = 0 To numFolders - 1
    LoopAllSubFolders folders(i)
Next i
End Sub
 
Upvote 0
yinkajewole said:
try this and give me a feedback
VBA Code: 
Sub TrialOwnWritten()
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Select the latest ILC folder from your desktop"
.Show
.AllowMultiSelect = False
If .SelectedItems.Count = 0 Then
MsgBox "You did not select a folder."
Exit Sub
End If
MyFolder = .SelectedItems(1) & "\"
End With
LoopAllSubFolders MyFolder
End Sub
Sub LoopAllSubFolders(ByVal folderPath As String)
Dim fileName As String
Dim fullFilePath As String
Dim numFolders As Long
Dim folders() As String
Dim i As Long
   Application.ScreenUpdating = False
Application.DisplayStatusBar = False
   Application.DisplayAlerts = False
    Sheets("Setup").Activate
Set Surveys = ActiveWorkbook.Sheets("Survey Returns")
Set FNCs = ActiveWorkbook.Sheets("FNC's")
If Right(folderPath, 1) <> "\" Then folderPath = folderPath & "\"
fileName = Dir(folderPath & "*.*", vbDirectory)
While Len(fileName) <> 0
    If Left(fileName, 1) <> "." Then
         fullFilePath = folderPath & fileName
         If (GetAttr(fullFilePath) And vbDirectory) = vbDirectory Then
            ReDim Preserve folders(0 To numFolders) As String
            folders(numFolders) = fullFilePath
            numFolders = numFolders + 1
        Else
           If Right(fileName, 5) = ".xlsx" Then
           Set wkbSource = Workbooks.Open(fileName:=folderPath & fileName)
            If InStr(1, fileName, "SURV", vbTextCompare) Then
            For x = 3 To 3
            If WorksheetFunction.CountA(Sheets(x).Cells) <> 0 Then
            With Sheets(x)
            LastRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
            End With
            With Surveys
            Sheets(x).UsedRange.Copy .Cells(.Rows.Count, "B").End(xlUp).Offset(2, 0)
            .Cells(.Rows.Count, "A").End(xlUp).Offset(2, 0).Resize(LastRow) = wkbSource.Name
            End With
            End If
            Next x
            ElseIf InStr(1, fileName, "EH", vbTextCompare) Then
            For x = 1 To 2
            If WorksheetFunction.CountA(Sheets(x).Cells) <> 0 Then
            With Sheets(x)
            LastRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
            End With
            With FNCs
            Sheets(x).UsedRange.Copy .Cells(.Rows.Count, "B").End(xlUp).Offset(2, 0)
            .Cells(.Rows.Count, "A").End(xlUp).Offset(2, 0).Resize(LastRow) = wkbSource.Name
            End With
            End If
            Next x
            End If
            wkbSource.Close False
        End If
        End If
    End If
    fileName = Dir()
Wend
For i = 0 To numFolders - 1
    LoopAllSubFolders folders(i)
Next i
End Sub
Click to expand...
Hi, initially it failed to even pick up the filenames, I noticed it was because the line "If Right(fileName, 5) = ".xlsx" Then" - most of the files are xls so I changed the line to "If InStr(fileName, "xls") Then". The code now runs as it should again on the test folder (Files only), but still not working through the sub folders. It seems to only loop through the files in the first sub folder it comes across, I changed the sub folders names and it done the opposite one from before, any idea?

Thanks, updated code below:

VBA Code: 
Sub newsheet()

With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Select the latest ILC folder from your desktop"
.Show
.AllowMultiSelect = False
If .SelectedItems.Count = 0 Then
MsgBox "You did not select a folder."
Exit Sub
End If
MyFolder = .SelectedItems(1) & "\"
End With
LoopAllSubFolders MyFolder
End Sub

Sub LoopAllSubFolders(ByVal folderPath As String)
Dim fileName As String
Dim fullFilePath As String
Dim numFolders As Long
Dim folders() As String
Dim i As Long

Application.ScreenUpdating = False
Application.DisplayStatusBar = False
Application.DisplayAlerts = False

Set Surveys = ActiveWorkbook.Sheets("Survey Returns")
Set FNCs = ActiveWorkbook.Sheets("FNC's")
If Right(folderPath, 1) <> "\" Then folderPath = folderPath & "\"
fileName = Dir(folderPath & "*.*", vbDirectory)
While Len(fileName) <> 0
If Left(fileName, 1) <> "." Then
fullFilePath = folderPath & fileName
If (GetAttr(fullFilePath) And vbDirectory) = vbDirectory Then
ReDim Preserve folders(0 To numFolders) As String
folders(numFolders) = fullFilePath
numFolders = numFolders + 1
Else
If InStr(fileName, "xls") Then

Set wkbSource = Workbooks.Open(fileName:=folderPath & fileName)

If InStr(fileName, "Surv") Then
For x = 3 To 3
If WorksheetFunction.CountA(Sheets(x).Cells) <> 0 Then
With Sheets(x)
On Error Resume Next
.Cells.UnMerge
On Error GoTo 0
LastRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
End With
With Surveys
Sheets(x).UsedRange.Copy .Cells(.Rows.Count, "B").End(xlUp).Offset(2, 0)
.Cells(.Rows.Count, "A").End(xlUp).Offset(2, 0).Resize(LastRow) = wkbSource.Name
End With
End If
Next x

ElseIf InStr(fileName, "EH") Then
For x = 1 To 2
If WorksheetFunction.CountA(Sheets(x).Cells) <> 0 Then
With Sheets(x)
On Error Resume Next
.Cells.UnMerge
On Error GoTo 0
LastRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
End With
With FNCs
Sheets(x).UsedRange.Copy .Cells(.Rows.Count, "B").End(xlUp).Offset(2, 0)
.Cells(.Rows.Count, "A").End(xlUp).Offset(2, 0).Resize(LastRow) = wkbSource.Name
End With
End If
Next x
End If
wkbSource.Close False
End If
End If
End If
fileName = Dir()
Wend
For i = 0 To numFolders - 1
LoopAllSubFolders folders(i)
Next i
End sub
 
Upvote 0
You must log in or register to reply here.

Similar threads

R
  • Question Question
Add a code or number at the end of the file name using VBA (Looped)
Replies
3
Views
122
HighAndWilder
H
M
  • Question Question
Copy File Names to Destination File
Replies
2
Views
326
metalscuba
M
W
  • Question Question
Help updating VBA code to use wildcard in the file name
Replies
1
Views
79
AlphaFrog
AlphaFrog
J
  • Question Question
Search folder for value and list left/right value
Replies
2
Views
229
JJCam
J
C
  • Question Question
VBA code stuck (extract data from worksheet)
Replies
1
Views
411
Alex Blakenburg
A

Forum statistics

Threads
1,224,823
Messages
6,181,181
Members
453,022
Latest member
Mohamed Magdi Tawfiq Emam

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