Selecting a folder and making it your filepath

Mugalh01

New Member
Joined
Mar 23, 2018
Messages
15
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
 

Excel Facts

Excel Can Read to You
Customize Quick Access Toolbar. From All Commands, add Speak Cells or Speak Cells on Enter to QAT. Select cells. Press Speak Cells.
Add a path seperator (\) to the end or the strPath.

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

Forum statistics

Threads
1,213,536
Messages
6,114,208
Members
448,554
Latest member
Gleisner2

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