Hello,
I have a macro that consolidates all filenames that start with "BDRIDGE" and have a "DATAx" sheet.name from all containing subfolders. The path of the subolders being added in the 1st sheet of the macro file.
My problem is that the macro does not retrieve anything as it only runs and creates a blank new sheet without data.
Any help please ?
I have a macro that consolidates all filenames that start with "BDRIDGE" and have a "DATAx" sheet.name from all containing subfolders. The path of the subolders being added in the 1st sheet of the macro file.
My problem is that the macro does not retrieve anything as it only runs and creates a blank new sheet without data.
Any help please ?
VBA Code:
Sub CopWKBooksInFolder()
Dim WS As Worksheet
Dim myfolder As String
Dim Str As String
Dim a As Single
Dim sht As Worksheet
Str = Application.InputBox(prompt:="Search only sheet names containing this string:", Title:="Search worksheet whose name contain this string:", Type:=2)
On Error Resume Next
Set Rng = Application.InputBox(prompt:="Select a cell range containing paths to folders" _
, Title:="Select a cell range", Default:=ActiveCell.Address, Type:=8)
On Error GoTo 0
Set WS = Sheets.Add
For Each cell In Rng
If Dir(cell.Value, vbDirectory) <> "" Then
chk = 0
Value = Dir(cell.Value)
Do Until Value = ""
If Value = "." Or Value = ".." Then
Else
If Left(Value, 6) = "BRIDGE" Then
On Error Resume Next
Workbooks.Open Filename:=cell.Value & Value
If Err.Number > 0 Then
Else
On Error GoTo 0
For Each sht In ActiveWorkbook.Worksheets
If InStr(sht.Name, Str) <> 0 Then
If sht.Range("A1") <> "" Then
Lrow = WS.Range("A" & Rows.Count).End(xlUp).Row + 1
If chk = 0 Then
sht.Range("A1").CurrentRegion.Copy Destination:=WS.Range("A" & Lrow)
chk = 1
Else
Set crng = sht.Range("A1").CurrentRegion
Set crng = crng.Offset(1, 0)
Set crng = crng.Resize(crng.Rows.Count - 1)
crng.Copy Destination:=WS.Range("A" & Lrow)
End If
End If
End If
Next sht
End If
Workbooks(Value).Close False
On Error GoTo 0
End If
End If
Value = Dir
Loop
End If
Next cell
Cells.EntireColumn.AutoFit
End Sub
