Hi All,
I have below code which allows user to open Folder containing excel file and then next code (InputDump) works on the opened file to extract data.
Now I want to replace the Folder Picker with C:\Test and run the second macro. I tried with the basic knowledge I have but its not allowing me to run the second macro.
No change is required in the "InputDump" code. Only change in Initial code to replace Folder Picker with direct file opening from C drive folder
Your quick response is highly appreciated. Thanks in advance
------------------------------------------------------------------------------------------
MOD EDIT: Added code tag
I have below code which allows user to open Folder containing excel file and then next code (InputDump) works on the opened file to extract data.
Now I want to replace the Folder Picker with C:\Test and run the second macro. I tried with the basic knowledge I have but its not allowing me to run the second macro.
No change is required in the "InputDump" code. Only change in Initial code to replace Folder Picker with direct file opening from C drive folder
Your quick response is highly appreciated. Thanks in advance
Code:
Option Explicit
Sub NewBCPull()
Dim foldName As String
Dim fileName As String
'Get folder location of Input files
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False
.InitialFileName = ThisWorkbook.path
.Title = "Please select folder with Input files"
.Show
If .SelectedItems.Count < 1 Then
'User aborted
Exit Sub
Else
foldName = .SelectedItems(1) & "\"
End If
End With
Application.ScreenUpdating = False
'Retrieve file names
fileName = Dir(foldName & "*.xl*")
'Retrieve each input file
Do While fileName <> ""
Call InputDump(foldName & fileName)
fileName = Dir()
Loop
Application.ScreenUpdating = True
End Sub
Sub InputDump(fName As String)
Dim wbSource As Workbook
Dim wbDest As Workbook
Dim fCell As Range
Dim fVal As Date
Dim wsSource As Worksheet
Dim wsDest As Worksheet
Dim vFile As Variant
Dim lastCol As Long
Dim lastRow As Long
Set wbDest = ThisWorkbook
Set wsDest = wbDest.Worksheets("Staffing Plan")
'Paste in new row
With wsDest
lastRow = .Cells(.Rows.Count, "D").End(xlUp).Row + 1
If lastRow < 1 Then lastRow = 1
End With
Set wbSource = Workbooks.Open(fileName:=fName, UpdateLinks:=False)
Set wsSource = wbSource.Worksheets("Staffing Plan")
'Find where to paste new data
fVal = wsSource.Range("J3").Value
Set fCell = wsDest.Range("1:1").Find(what:=fVal, LookIn:=xlFormulas, lookat:=xlWhole)
If fCell Is Nothing Then
MsgBox "Date not found, please correct Master sheet"
GoTo escapeClause
End If
With wsSource
'Find the last column of data
lastCol = .Cells(3, .Columns.Count).End(xlToLeft).Column
'Note that none of these copy over formatting. Used original code as a guide
'Insert file name
wsDest.Cells(lastRow, "B").Value = wbSource.Name
'Copy headings
wsSource.Range("A4:I150").Copy
wsDest.Cells(lastRow, "C").PasteSpecial xlPasteValues
wsDest.Cells(lastRow, "C").PasteSpecial xlPasteFormats
'Copy data below correct data
wsSource.Range("J4", .Cells(150, lastCol)).Copy
wsDest.Cells(lastRow, fCell.Column).PasteSpecial xlPasteValues
wsDest.Cells(lastRow, fCell.Column).PasteSpecial xlPasteFormats
End With
escapeClause:
Application.CutCopyMode = False
'Close input file, don't save any changes
wbSource.Close False
End Sub
------------------------------------------------------------------------------------------
MOD EDIT: Added code tag
Last edited by a moderator: