Using VBA to open files in a folder - excel

I would like to open the file automatically after clicking the button, the folder is the same and the file name is the same every month. I wanted it to always select the most recent file from teog msc, e.g. if not, it would say that the file is too old. However, And i get error now Object Variable or With Block not Set . Here
data_wb.Sheets("Adekwatnosc").Rows("1:1").Select
This code like a would like create .To open my file automatically
ThisMonth = Format(Date, "mmmm")
MyFolder = "C:\Users\V1410191\Documents\Final" & ThisMonth & ""
MyFile = Dir(MyFolder & "\FinalPrice*.xlsm")
Do Until MyFile = ""
MyFile = Dir
Set data_wb = Workbooks.Open(MyFile, UpdateLinks:=0)
Loop
And here is the code I have.
Dim vDate As Date
Dim wbMe As Workbook
Dim data_wb As Workbook
Dim ws As Worksheet
Dim inputbx As String
Dim loc As Range, lc As Long
Dim MyFolder As String, ThisMonth As String
Dim MyFile As String
'Set workbook'
Set wbMe = ActiveWorkbook
With wbMe.Sheets("input_forecast").Rows("1:1")
.Copy
.PasteSpecial Paste:=xlPasteValues
.NumberFormat = "YYYY-MM-DD"
End With
Application.ThisWorkbook.UpdateLinks = xlUpdateLinksNever '2
Application.DisplayAlerts = False
file_name = selectFilePK
If file_name = "" Then Exit Sub
Set data_wb = Workbooks.Open(file_name)
'paste copy like value and change to date format'
data_wb.Sheets("Adekwatnosc").Rows("1:1").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Selection.NumberFormat = "YYYY-MM-DD"
Do
inputbx = InputBox("Enter Date, FORMAT; YYYY-MM-DD", , Format(VBA.Now, "YYYY-MM-DD"))
If inputbx = vbNullString Then Exit Sub
On Error Resume Next
vDate = DateValue(inputbx)
On Error GoTo 0
DateIsValid = IsDate(vDate)
If Not DateIsValid Then MsgBox "Please enter a valid date.", vbExclamation
Loop Until DateIsValid
data_wb.Worksheets("Adekwatnosc").Activate
With data_wb.Worksheets("Adekwatnosc")
Set loc = .Cells.Find(what:=vDate)
If Not loc Is Nothing Then
lc = .Cells(loc.Row, Columns.Count).End(xlToLeft).Column
.Range(.Cells(109, loc.Column), .Cells(123, lc)).Copy
Set locPaste = wbMe.Sheets("input_forecast").Cells.Find(what:=vDate)
wbMe.Sheets("input_forecast").Cells(27, locPaste.Column).PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
End If
End With
data_wb.Close SaveChanges:=False
MsgBox "Wklejone!"
End Sub
Private Function selectFilePK()
Dim fd As Office.FileDialog
Set fd = Application.FileDialog(msoFileDialogFilePicker)
With fd
.InitialFileName = ActiveWorkbook.Path
.AllowMultiSelect = False
.Filters.Clear
.Filters.Add "Excel", "*.xlsm"
If .Show = True Then selectFilePK = .SelectedItems(1)
Application.ScreenUpdating = False
Application.AskToUpdateLinks = False
End With
End Function```

in your initial code:
ThisMonth = Format(Date, "mmmm")
MyFolder = "C:\Users\G2121290\Documents\PriceQ" & ThisMonth & "\"
MyFile = Dir(MyFolder & "\FinalPrice*.xlsx")
Do Until MyFile = ""
Set data_wb = Workbooks.Open(file_name, UpdateLinks:=0)
MyFile = Dir
Loop
in the Open statement you are using file_name instead of MyFile which you previously defined

Add a line that helps your debugging, like this:
file_name = selectFilePK
Debug.Print file_name
If file_name = "" Then Exit Sub
Press Ctrl+G to show the debug output before running. The value there is the file that is expected to be opened. If that is wrong in some way, adjust selectFilePK accordingly.

Related

Saving excel files to network drive takes too long using VBA

I have a macro which loops through excel files in a network drive path and performs few operations on the pivots and then tries to save the file in the same network path.
It works fine for the first 5 - 10 files and then it randomly stops saving the files.
The progress bar in the save box does not go any further.
Unable to save image
I have included the VBA code below
Sub CLEAR_ADI_PIVOT_DT_SRC()
Dim myPath As String
Dim myExtension As String
Dim myFile As String
Dim wb As Workbook
Dim ws As Worksheet
Dim FilePath As String
Dim PriorQuarter As String
Dim PrevQtrSheet As String
Dim filestr1 As String
Dim PrevQuarter As String
PrevQtrSheet = "Rebates Template " & Range("B2").Value
PrevQuarter = Range("B2").Value
PriorQuarter = Range("A2").Value
myPath = Range("I2").Value & "ADI\"
If Right(myPath, 1) <> "\" Then
myPath = myPath & "\"
End If
On Error GoTo ErrHandler
'Optimize Macro Speed
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
'Target File Extension (must include wildcard "*")
myExtension = "*.xl*"
'Target Path with Ending Extension
myFile = Dir(myPath & myExtension)
'Loop through each Excel file in folder
Do While myFile <> ""
'Set variable equal to opened workbook
Application.DisplayAlerts = False
Debug.Print myPath & myFile
Set wb = Workbooks.Open(filename:=myPath & myFile, UpdateLinks:=False)
wb.Worksheets("ADI").Visible = True
wb.Worksheets("ADI").Activate
Cells.Find(What:="totals:", After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Activate
ActiveCell.Offset(-1, 0).Select
Dim AdiClearRange As Range
Set AdiClearRange = Range("AE" & ActiveCell.Row, "C14")
AdiClearRange.Select
Selection.ClearContents
Range("B15").Select
'Insert rows in ADI sheet
Dim x As Long
For x = 1 To 500
Range("B19:AE19").Select
Selection.Copy
Selection.Insert Shift:=xlDown
Range("B14").Select
Application.CutCopyMode = False
Next x
'Delete prior quarter template sheet
For Each Sheet In wb.Worksheets
If Sheet.Name = "Rebates Template " & PriorQuarter Then
Sheet.Delete
End If
Next Sheet
'change data source of previous quarter pivots
'Get range of the previous template
wb.Worksheets(PrevQtrSheet).Activate
Range("AH5").Select
If ActiveSheet.AutoFilterMode Then ActiveSheet.AutoFilter.ShowAllData
ActiveSheet.Range("$A$5:$KD$683").AutoFilter Field:=34, Criteria1:="<>"
'ActiveSheet.Range("$A$5:$KD$683").AutoFilter Field:=34, Criteria1:="<>0"
Range("AH5").Select
Selection.End(xlDown).Select
'Change range of pivot 1 and pivot 7 and apply previous quarter filter in pivots
Dim rng As Range
Dim SourceAddress As String
Set rng = Range("A5", "AH" & ActiveCell.Row)
SourceAddress = "'" & PrevQtrSheet & "'" & "!" & "$A$5:" & ActiveCell.Address(RowAbsolute:=True, ColumnAbsolute:=True)
Debug.Print SourceAddress
Sheets("Check").Select
Dim myPivotField As PivotField
Dim filterValue As String
ActiveSheet.PivotTables("PivotTable3").ChangePivotCache wb.PivotCaches.Create(SourceType:=xlDatabase, SourceData:=SourceAddress)
ActiveSheet.PivotTables("PivotTable3").RefreshTable
ActiveSheet.Range("P1").Value = PrevQuarter
wb.Close SaveChanges:=True
'Get next file name
myFile = Dir
Loop
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
ResetSettings:
'Reset Macro Optimization Settings
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
ErrHandler:
'MsgBox Err.Description, vbExclamation
'Resume ResetSettings
End Sub

How to pull data from multiple workbooks in a folder?

I have hundreds of Excel (Microsoft® Excel® for Microsoft 365 MSO (16.0.14326.20702) 32-bit ) files in a folder which have one sheet in common.
For example- Let's consider the sheet as "data".
I want to pull specific cells (C2:C15) out of each of them and transpose them into a separate "masterfile".
This code runs unsuccessfully.
Sub ExtractData()
Dim masterfile As Workbook
Dim wb As Workbook
Dim directory As String
Dim fileName As String
Dim NextRow As Long
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Set masterfile = ThisWorkbook
directory = masterfile.Worksheets("Sheet1").Range("E1")
fileName = Dir(directory & "*.xl??")
Do While fileName <> ""
If fileName <> ThisWorkbook.Name Then
Set wb = Workbooks.Open(directory & fileName)
wb.Worksheets("data").Range("C2:C15").Copy
masterfile.Activate
NextRow = Cells(Rows.Count, "C").End(xlUp).Row + 1
Worksheets("Sheet1").Range("C" & NextRow).Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
wb.Close savechanges:=False
End If
fileName = Dir
Loop
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox "Data has been Compiled, Please Check!"
End Sub
Some suggestions:
Sub ExtractData()
Dim masterSheet As Worksheet
Dim wb As Workbook
Dim directory As String
Dim fileName As String, cDest As Range
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Set masterSheet = ThisWorkbook.Worksheets("Sheet1")
directory = masterSheet.Range("E1").Value
'### ensure trailing path separator ###
If Right(directory, 1) <> "\" Then directory = directory & "\"
'first paste location
Set cDest = masterSheet.Cells(masterSheet.Rows.Count, "C").End(xlUp).Offset(1)
fileName = Dir(directory & "*.xl??")
Do While fileName <> ""
If fileName <> ThisWorkbook.Name Then
Set wb = Workbooks.Open(directory & fileName)
wb.Worksheets("data").Range("C2:C15").Copy
cDest.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=True
Set cDest = cDest.Offset(1) 'next paste row
wb.Close savechanges:=False
End If
fileName = Dir
Loop
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox "Data has been Compiled, Please Check!"
End Sub

VBA Read Data from a Closed Excel File or Workbook without Opening it

I have code that completes my data, but I would like it to work in the background so that only input appears and then it copies the data to me. I added this to my code Application.ScreenUpdating = Falseit shows that it works remotely " in the background", the input box appears but then nothing happens, no error, but the data is not copied. How to change code ?
Sub Makro10()
Dim vDate As Date
Dim wbMe As Workbook
Dim data_wb As Workbook
Dim ws As Worksheet
Dim inputbx As String
Dim loc As Range, lc As Long
Dim app As New Excel.Application
'Set workbook'
Set wbMe = ActiveWorkbook
With wbMe.Sheets("input_forecast").Rows("1:1")
.Copy
.PasteSpecial Paste:=xlPasteValues
.NumberFormat = "YYYY-MM-DD"
End With
Application.CutCopyMode = False
file_name = selectFilePK
If file_name = "" Then Exit Sub
'Set data file
Set data_wb = app.Workbooks.Open(file_name)
'paste copy like value and change to date format'
data_wb.Sheets("Final").Rows("1:1").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Selection.NumberFormat = "YYYY-MM-DD"
Do
inputbx = InputBox("Enter Date, FORMAT; YYYY-MM-DD", , Format(VBA.Now, "YYYY-MM-DD"))
If inputbx = vbNullString Then Exit Sub
On Error Resume Next
vDate = DateValue(inputbx)
On Error GoTo 0
DateIsValid = IsDate(vDate)
If Not DateIsValid Then MsgBox "Please enter a valid date.", vbExclamation
Loop Until DateIsValid
data_wb.Worksheets("Final").Activate
With data_wb.Worksheets("Final")
Set loc = .Cells.Find(what:=vDate)
If Not loc Is Nothing Then
lc = .Cells(loc.Row, Columns.Count).End(xlToLeft).Column
.Range(.Cells(109, loc.Column), .Cells(123, lc)).Copy
Set locPaste = wbMe.Sheets("input_forecast").Cells.Find(what:=vDate)
wbMe.Sheets("input_forecast").Cells(27, locPaste.Column).PasteSpecial Paste:=xlPasteValues
End If
End With
data_wb.Close SaveChanges:=False
End Sub
Private Function selectFilePK()
Dim fd As Office.FileDialog
Set fd = Application.FileDialog(msoFileDialogFilePicker)
With fd
.InitialFileName = ActiveWorkbook.Path
.AllowMultiSelect = False
.Filters.Clear
.Filters.Add "Excel", "*.xlsm"
If .Show = True Then selectFilePK = .SelectedItems(1)
Application.ScreenUpdating = False
End With
End Function```

VBA need to cleanup code and simplify it if possible

I am still new to VBA, I am just curious if anyone has any recommendations for improving or simplifying this code. The program works fine the way it is, however it has to sort through anywhere from 10 to 30 files and marge them all. It can take a long time depending on the file size. The Excel files range from a few hundred lines to 800,000 each. Thanks for your help!
Option Compare Text
Sub MergeAllFiles()
Dim wb As Workbook
Dim myPath As String, MyFile As String, myExtension As String, Col1 As
String, MyFolder As String, Title As String
Dim i As Integer, j As Integer, WS_Count As Integer, k As Integer
Dim FldrPicker As FileDialog
Dim Mynote As String, Answer As String
Mynote = "Does each file have the same number of export fields?"
Answer = MsgBox(Mynote, vbQuestion + vbYesNo, "Confirmation Needed")
If Answer = vbNo Then
MsgBox "Cancelled"
GoTo ResetSettings
End If
j = 1
i = 1
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
'Retrieve Target Folder Path From User
Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Select A Target Folder"
.AllowMultiSelect = False
.Show
MyFolder = .SelectedItems(1)
Err.Clear
End With
Set NewBook = Workbooks.Add
With NewBook
.Title = "MasterList"
ActiveWorkbook.SaveAs Filename:="Mastersheet.xlsx"
End With
'Loop through each Excel file in folder
MyFile = Dir(MyFolder & "\", vbReadOnly)
If MyFile = "Batch.xlsx" Then GoTo NextLoop
Do While MyFile <> ""
DoEvents
Workbooks.Open Filename:=MyFolder & "\" & MyFile, UpdateLinks:=False
Title = ActiveWorkbook.Name
ActiveWorkbook.Sheets(i).Select
With ActiveWorkbook.Sheets(i)
If (ActiveSheet.AutoFilterMode And ActiveSheet.FilterMode)
Or ActiveSheet.FilterMode Then
ActiveSheet.ShowAllData
End If
End With
k = 1
l = 1
If j = 1 Then
k = 0
l = 0
End If
With Range("A1:AB1000000")
Set rFind = .Find(What:="Total Rate (Linehaul + Acc)",
LookAt:=xlWhole, MatchCase:=False, SearchFormat:=False)
ActiveSheet.Range("A1:ABC1000000").AutoFilter
Field:=rFind.Column, Criteria1:="="
ActiveSheet.Range("A1:ABC1000000").Offset(1,
0).SpecialCells(xlCellTypeVisible).EntireRow.Delete
ActiveSheet.AutoFilterMode = False
End With
ActiveSheet.UsedRange.Offset(l).Copy
Workbooks("Mastersheet.xlsx").Activate
Range("A" & Rows.Count).End(xlUp).Offset(k).Select
Selection.PasteSpecial Paste:=xlPasteAllExceptBorders,
Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Workbooks(Title).Activate
Application.CutCopyMode = False
Workbooks(MyFile).Close SaveChanges:=True
j = j + 1
If j = 50 Then Exit Do
NextLoop:
MyFile = Dir
Loop
ResetSettings:
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
Not sure if my code does exactly what yours does (had no sample data/input to check the output against), but maybe something like this:
Option Explicit
Private Sub MergeAllFiles()
If MsgBox("Does each file have the same number of export fields?", vbQuestion + vbYesNo, "Confirmation Needed") = vbNo Then
MsgBox "Files do not have same number of export fields. Code will stop running now."
Exit Sub
End If
'Retrieve Target Folder Path From User
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Select A Target Folder"
.AllowMultiSelect = False
.Show
If .SelectedItems.Count = 0 Then
MsgBox "Folder selection cancelled. Code will stop running now."
Exit Sub
End If
Dim folderPath As String
folderPath = .SelectedItems(1)
If VBA.Strings.StrComp(VBA.Strings.Right$(folderPath, 1), "\", vbBinaryCompare) <> 0 Then
folderPath = folderPath & "\"
End If
End With
Dim masterWorksheet As Worksheet
With Workbooks.Add
.SaveAs Filename:=ThisWorkbook.Path & "\Mastersheet.xlsx"
Set masterWorksheet = .Worksheets(1)
End With
' If you're only interested in .xlsx files, then maybe specify the file extension upfront
' when using dir(). This ensures you only loop through files with the given file extension.
' But if you do want multiple file extensions, you could remove extension from the dir()
' and just check file extension inside the loop.
Dim Filename As String
Filename = VBA.FileSystem.Dir$(folderPath & "*.xlsx", vbReadOnly)
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
Dim workbookToCopyFrom As Workbook
Dim fileCount As Long
Dim cellFound As Range
Dim blankRowsToDelete As Range
Dim lastRow As Long
Do While Len(Filename) <> 0
If VBA.Strings.StrComp(Filename, "Batch.xlsx", vbBinaryCompare) <> 0 Then
fileCount = fileCount + 1
Set workbookToCopyFrom = Application.Workbooks.Open(Filename:=folderPath & Filename, UpdateLinks:=False)
' Did you want to copy-paste from all worksheets
' or just the worksheet at the first index?
With workbookToCopyFrom.Worksheets(1)
If .AutoFilterMode Then .AutoFilter.ShowAllData
With .Range("A1:AB1000000")
' Presume this check is done because you want to include headers the first time,
' but exclude headers for any subsequent files.
If fileCount = 1 Then
.Rows(1).Copy masterWorksheet.Rows(1)
End If
Set cellFound = .Find(What:="Total Rate (Linehaul + Acc)", LookAt:=xlWhole, MatchCase:=False, SearchFormat:=False)
' It's worth checking if the previous line found anything
' If it didn't, you will get an error below when accessing the 'column' property
.AutoFilter Field:=cellFound.Column, Criteria1:="="
Set blankRowsToDelete = Application.Intersect(.EntireRow, .Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow)
If Not (blankRowsToDelete Is Nothing) Then
blankRowsToDelete.Delete
End If
.Parent.AutoFilterMode = False
End With
lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
If lastRow > 1 Then
.Range("A2:AB" & lastRow).Copy
masterWorksheet.Range("A" & .Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteAllExceptBorders, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
workbookToCopyFrom.Close SaveChanges:=False
End If
End With
If fileCount = 50 Then Exit Do
End If
DoEvents
Filename = Dir$()
Loop
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub

Copying a range from all files within a folder and pasting into master workbook

I'm fairly new to VBA so I apologize ahead of time. I've been getting involved with some complex operations and I would greatly appreciate some help or input.
With this macro, I am trying to:
Copy a specific range (2 column widths) from a specific sheet that is within all files in a given folder.
Paste the range values (and formatting if possible) in a column on the already open master workbook starting at B7 and moving over 2 columns for every new document so that the pasted data does not overlap.
Close files after copy/paste complete
As of right now I receive a
Run-time Error 9: Subscript out of range
for
Workbooks("RF_Summary_Template").Worksheets("Summary").Select
I know this is the least of my problems, though.
Below is my code:
Sub compile()
Dim SummaryFile As String, SummarySheet As String, summaryColumn As Long
Dim GetDir As String, Path As String
Dim dataFile As String, dataSheet As String, LastDataRow As Long
Dim i As Integer, FirstDataRow As Long
'********************************
RF_Summary_Template = ActiveWorkbook.Name 'summarybook
Summary = ActiveSheet.Name 'summarysheet
summaryColumn = Workbooks(RF_Summary_Template).Sheets(Summary).Cells(Columns.Count, 1).End(xlToLeft).Column + 1
CreateObject("WScript.Shell").Popup "First, browse to the correct directory, select ANY file in the directory, and click Open.", 2, "Select Install Base File"
GetDir = Application.GetOpenFilename("Excel Files (*.xls*), *.xls*")
If GetDir <> "False" Then
Path = CurDir & "\"
Else
MsgBox "Directory not selected"
Exit Sub
End If
Application.ScreenUpdating = False
dataFile = Dir(Path & "*.xls")
While dataFile <> ""
Workbooks.Open (dataFile)
Worksheets("Dashboard").Activate
ActiveSheet.Range("AY17:AZ35").Copy
Workbooks("RF_Summary_Template").Worksheets("Summary").Select
Range("B8").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Workbooks(dataFile).Close
summaryColumn = summaryColumn + 2
dataFile = Dir()
Wend
Workbooks(RF_Summary_Template).Save
Application.ScreenUpdating = True
End Sub
Thanks a million
I hope this helps. Run the procedure "CopyDataBetweenWorkBooks"
Sub CopyDataBetweenWorkbooks()
Dim wbSource As Workbook
Dim shTarget As Worksheet
Dim shSource As Worksheet
Dim strFilePath As String
Dim strPath As String
' Initialize some variables and
' get the folder path that has the files
Set shTarget = ThisWorkbook.Sheets("Summary")
strPath = GetPath
' Make sure a folder was picked.
If Not strPath = vbNullString Then
' Get all the files from the folder
strfile = Dir$(strPath & "*.xls", vbNormal)
Do While Not strfile = vbNullString
' Open the file and get the source sheet
Set wbSource = Workbooks.Open(strPath & strfile)
Set shSource = wbSource.Sheets("Dashboard")
'Copy the data
Call CopyData(shSource, shTarget)
'Close the workbook and move to the next file.
wbSource.Close False
strfile = Dir$()
Loop
End If
End Sub
' Procedure to copy the data.
Sub CopyData(ByRef shSource As Worksheet, shTarget As Worksheet)
Const strRANGE_ADDRESS As String = "AY17:AZ35"
Dim lCol As Long
'Determine the last column.
lCol = shTarget.Cells(8, shTarget.Columns.Count).End(xlToLeft).Column + 1
'Copy the data.
shSource.Range(strRANGE_ADDRESS).Copy
shTarget.Cells(8, lCol).PasteSpecial xlPasteValuesAndNumberFormats
' Reset the clipboard.
Application.CutCopyMode = xlCopy
End Sub
' Fucntion to get the folder path
Function GetPath() As String
With Application.FileDialog(msoFileDialogFolderPicker)
.ButtonName = "Select a folder"
.Title = "Folder Picker"
.AllowMultiSelect = False
'Get the folder if the user does not hot cancel
If .Show Then GetPath = .SelectedItems(1) & "\"
End With
End Function
I hope this helps :)
With the help of this code you can copy all workbooks and worksheets data
into one workbook
Sub copydata()
Dim fso As Scripting.FileSystemObject
Dim fill As Scripting.File
Dim oldfolder As String
Dim newfolder As String
Dim subfolder As Folder
Dim myfolder As Folder
Dim fd As FileDialog
Dim loopcount As Integer
Dim wb
Dim wb2 As Workbook
Dim rr As Range
Set fso = New Scripting.FileSystemObject
Set wb = ThisWorkbook
Set fd = Application.FileDialog(msoFileDialogFolderPicker)
fd.Title = "Please Select Folder to copy"
fd.ButtonName = "Go!"
fd.Show
oldfolder = fd.SelectedItems(1)
Set myfolder = fso.GetFolder(oldfolder)
'Application.ScreenUpdating = False
Application.EnableEvents = False
For Each subfolder In myfolder.SubFolders
For Each fill In subfolder.Files
If fill Like "*.xlsm" Or fill Like "*.xlsx" Or fill Like ".*xls" Then
'fill.Range("A1:Z100").Copy
Set wb2 = Application.Workbooks.Open(fill,0 , True)
wb2.Activate
For loopcount = 1 To wb2.Worksheets.Count
wb2.Activate
Worksheets(loopcount).Activate
Range("A1:Z300").Copy 'Replace your range
wb.Activate
Sheet1.Activate
Set rr = Range("A:A").Find("", Range("A1"))
rr.Select
ActiveSheet.Paste
ActiveCell.Offset(1, 0).Select
Next loopcount
wb2.Close False
End If
Application.CutCopyMode = False
Debug.Print fill.Name
Next fill
Next subfolder
MsgBox "Done"
For Each fill In myfolder.Files
Application.DisplayAlerts = False
If fill Like "*.xlsm" Or fill Like "*.xlsx" Or fill Like ".*xls" Or fill Like "*.xlsb" Then
'fill.Range("A1:Z100").Copy
Set wb2 = Application.Workbooks.Open(fill, 0, True)
wb2.Activate
For loopcount = 1 To wb2.Worksheets.Count
wb2.Activate
Worksheets(loopcount).Activate
Range("A:Z").EntireColumn.Hidden = False
Range("A1:Z1").AutoFilter
Range("A1:Z300").Copy
wb.Activate
Sheet1.Activate
Set rr = Range("A:A").Find("", Range("A1"))
rr.Select
ActiveSheet.Paste
ActiveCell.Offset(1, 0).Select
Next loopcount
wb2.Close False
End If
Application.CutCopyMode = False
Debug.Print fill.Name
Next fill
Application.EnableEvents = True
End Sub
Sub fdsdf()
'template is in the f_path
'files are under fpath\Raw Data\Ban
f_path = tree
Set wbTemplate = Workbooks.Open(Filename:=f_path & "\DEMAND_Template.xlsx")
MyFolder = f_path & "\Raw Data\Ban"
MyFile = Dir(MyFolder & "\*.xlsx")
Do While MyFile <> ""
Set wbIB = Workbooks.Open(Filename:=MyFolder & "\" & MyFile)
wbIB.Activate
Sheets("Sheet1").Select
r_cnt = ActiveSheet.UsedRange.Rows.Count
ran1 = "12:" & r_cnt
Rows(ran1).Select
Selection.Copy
wbTemplate.Select
Sheets("Sheet1").Select
r_cnt1 = ActiveSheet.UsedRange.Rows.Count
ran2 = Sheets("Sheet1").Range("A1048576").End(xlUp).Row + 1
Range("A" & ran2).Select
ActiveSheet.Paste
Application.CutCopyMode = False
wbIB.Close False
MyFile = Dir
Loop
wbTemplate.Save
End Sub
Sub final_consolidate()
f_path = "tree"
strFileToOpenIB = Application.GetOpenFilename(Title:="Please select the Consolidated file for Bangladesh", FileFilter:="Excel Files *.xlsx* (*.xlsx*),")
Set wbIB = Workbooks.Open(strFileToOpenIB)
wbIB.Activate
Sheets("Sheet1").Select
Sheets("Sheet1").Copy
wbIB.Activate
Sheets("Sheet2").Select
Sheets("Sheet2").Copy After:=Workbooks("Book1").Sheets(1)
wbIB.Activate
ActiveWorkbook.Close
Windows("Book1").Activate
strFileToOpenIB = Application.GetOpenFilename(Title:="Please select the Consolidated file for SriLanka", FileFilter:="Excel Files *.xlsx* (*.xlsx*),")
Set wbIB = Workbooks.Open(strFileToOpenIB)
wbIB.Activate
Sheets("Sheet1").Select
Sheets("Sheet1").Copy After:=Workbooks("Book1").Sheets(2)
wbIB.Activate
Sheets("Sheet2").Select
Sheets("Sheet2").Copy After:=Workbooks("Book1").Sheets(3)
wbIB.Activate
ActiveWorkbook.Close
Windows("Book1").Activate
ActiveWorkbook.SaveAs Filename:=f_path, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
End Sub

Resources