Hello
I need a little help with some VBA code I have inherited. I want to change it so that the user enters in the folder location in a cell on the first page of the workbook (Cell B3, work sheet name: Extract) as opposed to editing the macro each time they want to change folder location.
Please find the code below, any help would be very much appreciated as I am very new to this!
Code
Sub Extract_all_locations()
Dim LastRow As Long
Dim NextRow As Long
Dim col As Long
Dim strFile As String
Dim arrShts As Variant
Dim vSht As Variant
arrShts = Array("DS9", "Voyager", "Enterprise")
For Each vSht In arrShts
If Not IsSheet(ThisWorkbook.Sheets, CStr(vSht)) Then
Sheets.Add(After:=Sheets(Sheets.Count)).Name = vSht
End If
Next
Const strPath As String = "C:\Users\bsisko\Desktop\locations\"
strFile = Dir(strPath & "*.xls*")
col = 2
Application.ScreenUpdating = False
Do While strFile <> ""
With Workbooks.Open(strPath & strFile)
For Each vSht In arrShts
If IsSheet(.Sheets, CStr(vSht)) Then
ThisWorkbook.Sheets(vSht).Cells(1, col).Value = .Name
LastRow = .Sheets(vSht).Cells.Find("*", , , , 1, 2).Row
NextRow = ThisWorkbook.Sheets(vSht).Cells(Rows.Count, col).End(xlUp).Row + 1
ThisWorkbook.Sheets(vSht).Cells(NextRow, col).Resize(LastRow, 9).Value = .Sheets(vSht).Range("c1:k" & LastRow).Value
End If
Next vSht
.Close SaveChanges:=False
End With
col = col + 4
strFile = Dir
Loop
Application.ScreenUpdating = True
End Sub
Function IsSheet(shts As Sheets, strSheet As String) As Boolean
On Error Resume Next
IsSheet = LCase(shts(strSheet).Name) = LCase(strSheet)
End Function
Display More