VBA - DO while and filename contains*

[30136353]

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

    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

 

[yinkajewole]

This should loop all the subfolders

Sub newS()

Dim FSOLibrary As Object
Dim FSOFolder As Object
Dim folderName As String
Set FSOLibrary = CreateObject("Scripting.FileSystemObject")
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

LoopSubFolders FSOLibrary.GetFolder(MyFolder)

End Sub

Sub LoopSubFolders(FSOFolder As Object)
Dim FSOSubFolder As Object
Dim FSOFile As Object
Application.ScreenUpdating = False
Application.DisplayStatusBar = False
Application.DisplayAlerts = False

Set Surveys = ActiveWorkbook.Sheets("Survey Returns")
Set FNCs = ActiveWorkbook.Sheets("FNC's")

For Each FSOSubFolder In FSOFolder.subfolders
    LoopSubFolders FSOSubFolder
Next
For Each FSOFile In FSOFolder.Files
If InStr(FSOFile.Name, "xls") Then
If InStr(FSOFile.Name, "Surv") Then
Set wkbSource = Workbooks.Open(fileName:=FSOFile.Path)
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(FSOFile.Name, "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
wkbSource.Close False
End If
End If
Next

End Sub

 

[30136353]

This should loop all the subfolders

Sub newS()

Dim FSOLibrary As Object
Dim FSOFolder As Object
Dim folderName As String
Set FSOLibrary = CreateObject("Scripting.FileSystemObject")
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

LoopSubFolders FSOLibrary.GetFolder(MyFolder)

End Sub

Sub LoopSubFolders(FSOFolder As Object)
Dim FSOSubFolder As Object
Dim FSOFile As Object
Application.ScreenUpdating = False
Application.DisplayStatusBar = False
Application.DisplayAlerts = False

Set Surveys = ActiveWorkbook.Sheets("Survey Returns")
Set FNCs = ActiveWorkbook.Sheets("FNC's")

For Each FSOSubFolder In FSOFolder.subfolders
    LoopSubFolders FSOSubFolder
Next
For Each FSOFile In FSOFolder.Files
If InStr(FSOFile.Name, "xls") Then
If InStr(FSOFile.Name, "Surv") Then
Set wkbSource = Workbooks.Open(fileName:=FSOFile.Path)
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(FSOFile.Name, "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
wkbSource.Close False
End If
End If
Next

End Sub

That's completely not working now, seems to be copying sheet 1 from active workbook into FNC's sheet. Nothing else seems to be working either... Is there any way to modify the previous code slightly? Thanks