Selecting a folder and making it your filepath

[Mugalh01]

Morning all,

A little help please. I'm trying to open a folder and copy data from numerous files into the active sheet but have hit a few snags. I've tried to make my file path a cell reference in a sheet with an ActiveX button (where the user pastes the file path for the desired folder) and it works but whenever I press the button, the user information/instructions I've got in that sheet is/are wiped away so the new user no longer knows what to do. So I've tried using FileDialog to select a folder but I can't get the code to keep the file path and carry on through to collecting the data. A solution to either problem would be greatly appreciated. My code (using the filedialog) is as below.

Thank you

Private Sub Copydata_Click()


Dim wbSource As Workbook
Dim shTarget As Worksheet
Dim shTarget2 As Worksheet
Dim shSource As Worksheet
Dim strFilePath As String
Dim strPath As String
Dim Folder As FileDialog
Dim myloop


'select Folder
Set Folder = Application.FileDialog(msoFileDialogFolderPicker)
If Folder.Show = -1 Then
strPath = Folder.SelectedItems(1)

Set shTarget = ThisWorkbook.Sheets("Mutation data")
Set shTarget2 = ThisWorkbook.Sheets("Labnos")


' Get all the files from the folder
strFilePath = Dir(strPath & "*xlsx")

Do While Not strFilePath = vbNullString

' Open the file and get the source sheet
Set wbSource = Workbooks.Open(strPath & strFilePath, 0)
Set shSource = wbSource.Sheets("Summary")

'copy data from source workbook

With shTarget
Dim lRow As Long, rng As Range, rng2 As Range
Set rng = shSource.Range("A12:G17")
Set rng2 = shSource.Range("A4")
lRow = .Cells(.Rows.Count, "A").End(xlUp).Row + 1

rng.Copy
shTarget.Range("A" & lRow).PasteSpecial xlPasteValues
rng2.Copy
shTarget.Range("H" & lRow).PasteSpecial xlPasteValues
.Range(.Cells(lRow, "A"), .Cells(lRow + rng.Rows.Count - 1, "G")).Value = rng.Value
.Range(.Cells(lRow, "H"), .Cells(lRow + rng.Rows.Count - 1, "H")).Value = rng2.Value
Application.CutCopyMode = False

End With
'delete rows with zeros
For myloop = shTarget.Range("A" & lRow).Row To 1 Step -1
If Cells(myloop, 4).Value = 0 Then Rows(myloop).EntireRow.Delete

Next

With shTarget2
Set rng2 = shSource.Range("A4")
lRow = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
rng2.Copy
shTarget2.Range("A" & lRow).PasteSpecial xlPasteValues
Application.CutCopyMode = False
End With


'Close the workbook and move to the next file.
wbSource.Close False
strFilePath = Dir$()

Loop
End If
End Sub

 

[AlphaFrog]

Add a path seperator (\) to the end or the strPath.

Set Folder = Application.FileDialog(msoFileDialogFolderPicker)
If Folder.Show = -1 Then
strPath = Folder.SelectedItems(1) [COLOR=#FF0000]& "\"[/COLOR]

 

[Mugalh01]

Nice one AlphaFrog.
Works Like a charm.
Thanks again