Softcode Path from File Open dialog

M

Max

Ref the line: MyPath = "C:\" in the sub below (from Mike H)
how can I make the path (the "C:\" bit) as a variable for the sub/Excel to
pick up? The path will be different everyday. I'd navigate to the desired
folder upon running the sub (via a "File>Open"), then the sub will do the
rest of the processes on the files in that folder. Thanks.

Sub LoopThroughDirectory()
Application.DisplayAlerts = False
'Change this to your directory
MyPath = "C:\"
Dim wbNew As Workbook
Set wbNew = Workbooks.Add()
wbNew.SaveAs Filename:=MyPath & "1234.xls"
For x = 1 To 4
Workbooks.Open Filename:=MyPath & x & ".xls"
'Here is the line that calls the macro below, passing the workbook to it
DoSomething ActiveWorkbook
ActiveWorkbook.Close savechanges:=False
Next
Application.DisplayAlerts = True
End Sub
 
S

Sam Wilson

Change

MyPath = "C:\"

to this:

Dim fd As FileDialog
Set fd = Application.FileDialog(msoFileDialogFilePicker)
fd.Show
mypath = fd.SelectedItems(1)
 
J

Jacob Skaria

Max, modified the macro to display the SaveAsDialog, and assign that file
path as myPath for you to proceed...Try and feedback

Sub LoopThroughDirectory()
Dim wbNew As Workbook, myPath As String, varFile As Variant

Application.DisplayAlerts = False
varFile = Application.GetSaveAsFilename
If varFile = False Then Exit Sub
myPath = Left(varFile, InStrRev(varFile, "\"))

Set wbNew = Workbooks.Add()
wbNew.SaveAs Filename:=varFile
For x = 1 To 4
Workbooks.Open Filename:=myPath & x & ".xls"
'Here is the line that calls the macro below, passing the workbook to it
' DoSomething ActiveWorkbook
ActiveWorkbook.Close savechanges:=False
Next
Application.DisplayAlerts = True

End Sub

If this post helps click Yes
 
S

Sam Wilson

Nearly forgot, also change:

wbNew.SaveAs Filename:=MyPath & "1234.xls"


to just

wbNew.SaveAs Filename:=MyPath
 
M

Max

Thanks Jacob. Afraid I had difficulties trying it out. My original thread
where Mike responded is at: http://tinyurl.com/yewknly
Could I trouble you to check out my objectives/feedback to Mike (but I
received no further reply from Mike) over there, which might explain it
better? I need to fire the sub from somewhere independent (eg from
Personal.xls), then "point" it to the particular folder with the 4 files
(1.xls, 2.xls, 3.xls & 4.xls) and then leave the sub to do the rest of the
job ... creating a 1234.xls, saving this file into that particular folder,
and stack up all the data from 1.xls, 2.xls, 3.xls & 4.xls.
 
M

Max

Thanks Sam. I'm afraid I had difficulties trying out your response.
My original thread where Mike responded is at: http://tinyurl.com/yewknly
Could I trouble you to check out my objectives/feedback to Mike (but I
received no further reply from Mike) over there, which might explain it
better? I need to fire the sub from somewhere independent (eg from
Personal.xls), then "point" it to the particular folder with the 4 files
(1.xls, 2.xls, 3.xls & 4.xls) and then leave the sub to do the rest of the
job ... creating a 1234.xls, saving this file into that particular folder,
and stack up all the data from 1.xls, 2.xls, 3.xls & 4.xls.
 
J

Jacob Skaria

I thought I have responded..OK...I have read your responses to Mike in
MSwebnewsreader itself. If I understand you correctly the below would belp

'Modify your Sub as below; So that myPath is an argument be passed while
calling 'this sub
Sub LoopThroughDirectory(myPath as String)
'your code
End Sub

'From personal.xls
LoopThroughDirectory "C:\temp\"


If this post helps click Yes
 
S

Sam Wilson

Sub LoopThroughDirectory()

Application.DisplayAlerts = False

Dim fd As FileDialog
Set fd = Application.FileDialog(msoFileDialogFolderPicker)
fd.Show
mypath = fd.SelectedItems(1) & "\"

Dim wbNew As Workbook
Set wbNew = Workbooks.Add()
wbNew.SaveAs Filename:=MyPath & "1234.xls"
For x = 1 To 4
Workbooks.Open Filename:=MyPath & x & ".xls"
'Here is the line that calls the macro below, passing the workbook to it
DoSomething ActiveWorkbook
ActiveWorkbook.Close savechanges:=False
Next
Application.DisplayAlerts = True
End Sub
 
M

Max

Many thanks, Sam. Tested using your revision on the sub and it works fine in
picking it up from the dialog, and proceeding from there.

Could I have your help here on the last bit, that stacking part carried out
by Mike's
Sub DoSomething(Book As Workbook). I've pasted below the entire routine
which I just tested. Somehow the stacking sub misses capturing 2 lines, which
I checked were the last data lines in 1.xls and 2.xls. For info, my test
source 3.xls had zero data lines (it had only the row1 col headers). Thanks

-------------------------
Sub LoopThroughDirectory()

Application.DisplayAlerts = False

Dim fd As FileDialog
Set fd = Application.FileDialog(msoFileDialogFolderPicker)
fd.Show
myPath = fd.SelectedItems(1) & "\"

Dim wbNew As Workbook
Set wbNew = Workbooks.Add()
wbNew.SaveAs Filename:=myPath & "1234.xls"
For x = 1 To 4
Workbooks.Open Filename:=myPath & x & ".xls"
'Here is the line that calls the macro below, passing the workbook to it
DoSomething ActiveWorkbook
ActiveWorkbook.Close savechanges:=False
Next
Application.DisplayAlerts = True
End Sub

Sub DoSomething(Book As Workbook)
lastrow = Cells(Cells.Rows.Count, "B").End(xlUp).Row

If ActiveWorkbook.Name = "1.xls" Then
ActiveSheet.Rows("1:" & lastrow).Copy
Else
ActiveSheet.Rows("2:" & lastrow).Copy
End If
lastrowNew = Windows("1234.xls").ActiveSheet.Cells(Cells.Rows.Count,
"B").End(xlUp).Row
Windows("1234.xls").ActiveSheet.Range("A" & lastrowNew).PasteSpecial
End Sub
 
J

Jacob Skaria

--Modified the DoSomthing Sub.

--In Sub LoopThroughDirectory call DoSomething as below
DoSomething ActiveWorkbook, wbNew

Sub DoSomething(Book As Workbook, Book1 As Workbook)
Dim ws As Worksheet
Set ws = Book.Sheets(1)
lastrow = ws.Cells(Cells.Rows.Count, "B").End(xlUp).Row

If UCase(Book.Name) = "1.XLS" Then
ws.Rows("1:" & lastrow).Copy
Else
ws.Rows("2:" & lastrow).Copy
End If
lastrowNew = Book1.ActiveSheet.Cells(Cells.Rows.Count, _
"B").End(xlUp).Row
Book1.ActiveSheet.Range("A" & lastrowNew).PasteSpecial
Application.CutCopyMode = False
End Sub

If this post helps click Yes
 
M

Max

Jacob, many thanks. Need to test this at the office tomorrow.
Will feedback further here promptly. cheers.
 
M

Max

Jacob, The 2 missed out lines are still there I'm afraid. Pasted below is the
entire routine which I tested. I have re-checked that the 2 missed out lines
were, as before, the last data lines in 1.xls and 2.xls. My test source 3.xls
had zero data lines (it had only the row1 col headers). Grateful for any
further help to resolve this. Thanks

------------------------
Sub LoopThroughDirectory()

Application.DisplayAlerts = False

Dim fd As FileDialog
Set fd = Application.FileDialog(msoFileDialogFolderPicker)
fd.Show
myPath = fd.SelectedItems(1) & "\"

Dim wbNew As Workbook
Set wbNew = Workbooks.Add()
wbNew.SaveAs Filename:=myPath & "1234.xls"
For x = 1 To 4
Workbooks.Open Filename:=myPath & x & ".xls"
'Here is the line that calls the macro below, passing the workbook to it
'DoSomething ActiveWorkbook
DoSomething ActiveWorkbook, wbNew
ActiveWorkbook.Close savechanges:=False
Next
Application.DisplayAlerts = True
End Sub

Sub DoSomething(Book As Workbook, Book1 As Workbook)
Dim ws As Worksheet
Set ws = Book.Sheets(1)
lastrow = ws.Cells(Cells.Rows.Count, "B").End(xlUp).Row

If UCase(Book.Name) = "1.XLS" Then
ws.Rows("1:" & lastrow).Copy
Else
ws.Rows("2:" & lastrow).Copy
End If
lastrowNew = Book1.ActiveSheet.Cells(Cells.Rows.Count, _
"B").End(xlUp).Row
Book1.ActiveSheet.Range("A" & lastrowNew).PasteSpecial
Application.CutCopyMode = False
End Sub
 
J

Jacob Skaria

Missed to mention +1 ...Try the below...

Sub DoSomething(Book As Workbook, Book1 As Workbook)
Dim ws As Worksheet
Set ws = Book.Sheets(1)
lastrow = ws.Cells(Cells.Rows.Count, "B").End(xlUp).Row
If UCase(Book.Name) = "1.XLS" Then
ws.Rows("1:" & lastrow).Copy
Else
ws.Rows("2:" & lastrow).Copy
End If
lastrowNew = Book1.ActiveSheet.Cells(Cells.Rows.Count, _
"B").End(xlUp).Row
Book1.ActiveSheet.Range("A" & lastrowNew+1).PasteSpecial
Application.CutCopyMode = False
End Sub

If this post helps click Yes
 
M

Max

Tested your revision, Jacob. As-is, what happens now is that in the stacked
output sheet, the header row gets pushed down to row2, and another header row
(from 3.xls, which has zero data) gets written into the stack which is not
supposed to happen. A fine check reveals that all data lines are there
(including the 2 missed out earlier) so data-wise, its ok. Could something be
done to get the header row back to row1, and for the sub to be able to handle
any zero data line cases (like 3.xls in this instance) without stacking the
header row in-between? Thanks
 
J

Jacob Skaria

Try this version...and feedback

Sub DoSomething(Book As Workbook, Book1 As Workbook)
Dim ws As Worksheet, lastRow As Long, lastrowNew As Long
Set ws = Book.Sheets(1)
lastRow = ws.Cells(Cells.Rows.Count, "B").End(xlUp).Row
If UCase(Book.Name) = "1.XLS" Then
ws.Rows("1:" & lastRow).Copy
Book1.ActiveSheet.Range("A1").PasteSpecial
Else
If lastRow > 1 Then
ws.Rows("2:" & lastRow).Copy
lastrowNew = Book1.ActiveSheet.Cells(Cells.Rows.Count, _
"B").End(xlUp).Row
Book1.ActiveSheet.Range("A" & lastrowNew + 1).PasteSpecial
End If
End If
Application.CutCopyMode = False
End Sub

If this post helps click Yes
 

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Similar Threads

Code execution is correct but generates Error :The file you aretrying to open is in a different form 3
Need a little help coping a sheet from one workbook to another. 2
modify macro to execute based on current path 6
Copy item from Outlook to folder via Excel 12
save and exit macro 8
error while running macro, but not if stepping through lines. 3
Save file to Specific Directory - then EMAIL 2
VBA - exporting serial letters to single documents 0

Top