Excel keeps crashing - Combing files - excel

I am using the below script to combine files in a folder after capturing file name in cell. It used to work fine but excel keeps crashing when I ran this today.
There are no syntax errors in the code. I am unable to figure out how to make this code run.
code:
Sub Button_Click2()
Dim SummarySheet As Worksheet
Dim FolderPath As String
Dim NRow As Long
Dim FileName As String
Dim WorkBk As Workbook
Dim SourceRange As Range
Dim DestRange As Range
Dim TemplatePath As String
TemplatePath = Application.ActiveWorkbook.Path
' Create a new workbook and set a variable to the first sheet.
Set SummarySheet = Workbooks.Add(xlWBATWorksheet).Worksheets(1)
' Modify this folder path to point to the files you want to use.
FolderPath = TemplatePath & "\"
' NRow keeps track of where to insert new rows in the destination workbook.
NRow = 1
' Call Dir the first time, pointing it to all Excel files in the folder path.
FileName = Dir(FolderPath & "*.xls*")
' Loop until Dir returns an empty string.
Do While FileName <> ""
' Open a workbook in the folder
Set WorkBk = Workbooks.Open(FolderPath & FileName)
' Set the cell in column A to be the file name.
SummarySheet.Range("A" & NRow).Value = FileName
' Set the source range to be A9 through C9.
' Modify this range for your workbooks.
' It can span multiple rows.
Dim LastRow As Long
LastRow = WorkBk.Worksheets(1).Cells.Find(What:="*", _
After:=WorkBk.Worksheets(1).Cells.Range("A1"), _
SearchDirection:=xlPrevious, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows).Row
Set SourceRange = WorkBk.Worksheets(1).Range("A1:AA" & LastRow)
' Set the destination range to start at column B and
' be the same size as the source range.
Set DestRange = SummarySheet.Range("B" & NRow)
Set DestRange = DestRange.Resize(SourceRange.Rows.Count, _
SourceRange.Columns.Count)
' Copy over the values from the source to the destination.
DestRange.Value = SourceRange.Value
' Increase NRow so that we know where to copy data next.
NRow = NRow + DestRange.Rows.Count
' Close the source workbook without saving changes.
WorkBk.Close savechanges:=False
' Use Dir to get the next file name.
FileName = Dir()
Loop
' Call AutoFit on the destination sheet so that all
' data is readable.
SummarySheet.Columns.AutoFit
End Sub
Screenshot of crash:

Related

Copying values from multiple workbooks to specific cells in a master

HiHi,
disclaimer: I have no experience with coding
I have a code which takes values from cells (B2:C2) from multiple worksheets in a folder on my desktop and pasts it into the master workbook. This works great, however, I don't want the copied cells pasted consecutively down cells (F3:G3)- they need to be pasted into specific cells. This sounds complicated, and I'm sure it is. First, here's my base code which I have modified (from this code) to fit my needs:
Sub MergeAllWorkbooks()
Dim SummarySheet As Worksheet
Dim FolderPath As String
Dim FileName As String
Dim WorkBk As Workbook
Dim SourceRange As Range
Dim DestRange As Range
'Optimize Macro Speed
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
' Set summarysheet to activeworkbook/activesheet where the macro runs
Set SummarySheet = ActiveWorkbook.ActiveSheet
' Modify this folder path to point to the files you want to use.
FolderPath = "C:\Users\Me\Desktop\Extracted Data\16.12.2021\"
' Call Dir the first time, pointing it to all Excel files in the folder path.
FileName = Dir(FolderPath & "*.csv*")
' Loop until Dir returns an empty string.
Do While FileName <> ""
' Open a workbook in the folder
Set WorkBk = Workbooks.Open(FolderPath & FileName)
'loop through all Sheets in WorkBk
For Each sh In WorkBk.Worksheets
' Set the source range to be A9 through C9.
Set SourceRange = Sheets(sh.Name).Range("B2:C2")
' Set the destination range to start at column B and
' be the same size as the source range.
Set DestRange = SummarySheet.Range("F" & SummarySheet.Range("F" & Rows.Count).End(xlUp).Row + 1)
Set DestRange = DestRange.Resize(SourceRange.Rows.Count, _
SourceRange.Columns.Count)
' Copy over the values from the source to the destination.
DestRange.Value = SourceRange.Value
Next sh
' Close the source workbook without saving changes.
WorkBk.Close savechanges:=False
' Use Dir to get the next file name.
FileName = Dir()
Loop
' Call AutoFit on the destination sheet so that all
' data is readable.
ActiveSheet.Columns.AutoFit
'Message Box when tasks are completed
MsgBox "Task Complete!"
End Sub
So, this runs and does copy the values from each workbook within the source folder to the master. I want to make it so that:
If it copies from a work book that contains i.e "282579" and "Ch.4" to the cells that correspond to those values. To clarify, I have added a Screenshot of my master workbook.
If it copies a value from a source workbook with a title that contains 282579 and Ch.4, it will paste those 2 values into 282579's Ch.4 cell located at (F10:G10) and so on.
Tried using the If function (like, If (workbook has this in its name) but I have no idea how to specify which cells it needs to be pasted in)
I hope I have made sense and that this is understandable.
edit: if a copy of the data I use is needed, I can supply it
Use a Regular Expression to extract the SN and Ch. numbers from the filename. Use Find to located the SN on the summary sheet then scan the merged rows for the Ch number.
Sub MergeAllWorkbooks()
' Modify this folder path to point to the files you want to use.
Const FolderPath = "C:\Users\Me\Desktop\Extracted Data\16.12.2021\"
Dim wb As Workbook, wbCSV As Workbook
Dim ws As Worksheet, wsCSV As Worksheet
Dim rngCSV As Range, fnd As Range, bFound As Boolean
Dim Filename As String, n As Long, i As Long
' Set summarysheet to activeworkbook/activesheet where the macro runs
Set wb = ActiveWorkbook
Set ws = wb.ActiveSheet
' regular expression to extract numbers
' example VS SAAV_282579 ch 4 Data.csv
Dim Regex As Object, m As Object, SN As Long, CH As Long
Set Regex = CreateObject("vbscript.regexp")
With Regex
.IgnoreCase = True
.Pattern = "(_(\d+) +ch +(\d+) +Data)"
End With
' Call Dir the first time, pointing it to all Excel files in the folder path.
Filename = Dir(FolderPath & "*Data.csv*")
' Loop until Dir returns an empty string.
Application.ScreenUpdating = False
Do While Filename <> ""
' extract SN and Ch from filename
If Regex.test(Filename) Then
Set m = Regex.Execute(Filename)(0).submatches
SN = m(1)
CH = m(2)
Debug.Print Filename, SN, CH
' Find SN
Set fnd = ws.Range("B:B").Find(SN, LookIn:=xlValues, lookat:=xlWhole)
If fnd Is Nothing Then
MsgBox SN & " not found !", vbCritical, Filename
Else
' find ch.
bFound = False
For i = 0 To fnd.MergeArea.Count - 1
If ws.Cells(fnd.Row + i, "D") = CH Then ' Col D
bFound = True
' Open a workbook in the folder
Set wbCSV = Workbooks.Open(FolderPath & Filename, ReadOnly:=True)
ws.Cells(fnd.Row + i, "F").Resize(, 2).Value2 = wbCSV.Sheets(1).Range("B2:C2").Value2
' Close the source workbook without saving changes.
wbCSV.Close savechanges:=False
Exit For
End If
Next
If bFound = False Then
MsgBox "Ch." & CH & " not found for " & SN, vbExclamation, Filename
End If
End If
n = n + 1
Else
Debug.Print Filename & " skipped"
End If
' Use Dir to get the next file name.
Filename = Dir()
Loop
' Call AutoFit on the destination sheet so that all
' data is readable.
ws.Columns.AutoFit
Application.ScreenUpdating = True
'Message Box when tasks are completed
MsgBox n & " csv files found.", vbInformation, "Task Complete!"
End Sub
From your explanation it is not clear if you are able to match the source worksheets with a specific Ch. If you can, I'd advise to define a Ch variable soon after the For each sh loop, then you need to initiate another loop in the master workbook on column D for each row until you get the row number of the Ch variable. You use the row number to define the destination range
Dim SummarySheet As Worksheet
Dim FolderPath As String
Dim FileName As String
Dim WorkBk As Workbook
Dim SourceRange As Range
Dim DestRange As Range
Dim n As Long 'Ch substring position
Dim Ch As String 'Ch variable for source file
Dim LastChRow As Long 'lastrow of Ch in summary sheet
Dim ChSummary As String 'Define the Ch string in summary sheet
'Optimize Macro Speed
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
' Set summarysheet to activeworkbook/activesheet where the macro runs
Set SummarySheet = ActiveWorkbook.ActiveSheet
' Define LastChRow
LastChRow = SummarySheet.Cells(Rows.Count, "D").End(xlUp).Row
' Modify this folder path to point to the files you want to use.
FolderPath = "C:\Users\Me\Desktop\Extracted
Data\16.12.2021\"
' Call Dir the first time, pointing it to all Excel files in the
folder path.
FileName = Dir(FolderPath & "*.csv*")
' Loop until Dir returns an empty string.
Do While FileName <> ""
'define starting charachter of Ch source file for string manipulation
n = InStr(FileName, "Ch")
'define Ch variable
Ch = Trim(Mid(FileName, n, 5))
' Open a workbook in the folder
Set WorkBk = Workbooks.Open(FolderPath & FileName)
'loop through all Sheets in WorkBk
For Each sh In WorkBk.Worksheets
For i = 3 To LastChRow
'Define ChSummary variable in loop
ChSummary = "Ch" & " " & SummarySheet.Range("D" & i)
If ChSummary = Ch Then
' Set the source range to be A9 through C9.
Set SourceRange = Sheets(sh.Name).Range("B2:C2")
' Set the destination range to start at column B and
' be the same size as the source range.
Set DestRange = SummarySheet.Range("F" & i & ":G" & i)
'Set DestRange = DestRange.Resize(SourceRange.Rows.Count, _
' SourceRange.Columns.Count)
' Copy over the values from the source to the destination.
DestRange.Value = SourceRange.Value
End If
Next i
Next sh
' Close the source workbook without saving changes.
WorkBk.Close savechanges:=False
' Use Dir to get the next file name.
FileName = Dir()'

"Operation Search and Merge": VBA

I've been trying to scavange together a macro which will merge several .CSV files.
However, the data I need in said file (GPS data) is located in different rows of column A. I therefor need it to search for part of a string, in this case there are a few strings related to GPS, but I only need GPS latitud and longitude (which will always be found one after another).
Any help is appreciated! The code might look a bit.. like shit, ive been trying to mess with it to make it work together!
Sub MergeAllWorkbooks()
Dim SummarySheet As Worksheet
Dim FolderPath As String
Dim directory As Object
Dim NRow As Long
Dim FileName As String
Dim WorkBk As Workbook
Dim SourceRange As Range
Dim DestRange As Range
Dim S_Lat, S_Long, D_Lat, D_Long As Range
Dim i As Integer
Dim icount As Integer
Dim icount2 As Integer
Application.ScreenUpdating = False
Application.DisplayAlerts = False
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False
If .Show = -1 Then '-1 = yes or true
FolderPath = .SelectedItems(1) & "\"
Else
MsgBox "FilePath not selected!", , "Path selecter"
Exit Sub
End If
End With
' Create a new workbook and set a variable to the first sheet.
Set SummarySheet = Workbooks.Add(xlWBATWorksheet).Worksheets(1)
' NRow keeps track of where to insert new rows in the destination workbook.
NRow = 2
' Call Dir the first time, pointing it to all .csv files in the folder path.
FileName = dir(FolderPath & "*.csv")
SummarySheet.Range("A1") = "Filnamn"
SummarySheet.Range("B1") = "Latitud"
SummarySheet.Range("C1") = "Longitud"
' Loop until Dir returns an empty string.
Do While FileName <> ""
' Open a workbook in the folder
Set WorkBk = Workbooks.Open(FolderPath & "\" & FileName)
' Set the cell in column A to be the file name.
SummarySheet.Range("A" & NRow).Value = FileName
' Set the source range to be A9 through C9.
' Modify this range for your workbooks.
' It can span multiple rows.
For i = 1 To 200
If InStr(1, LCase(Range("A" & i)), "GPS Latitude") <> 0 Then 'If GPS appears in the string then
icount = i
icount2 = icount + 1
Set S_Lat = WorkBk.Worksheets(1).Range("A" & icount) ' Set the S_Lat variable
Set S_Long = WorkBk.Worksheets(1).Range("A" & icount2) ' Set the S_Long variable
Exit For
End If
Next i
' Set the destination range to start at column B and
' be the same size as the source range.
' SummarySheet.Range("B" & NRow).Value = S_Lat.Value ***** Didnt work? ******
' SummarySheet.Range("C" & NRow).Value = S_Long.Value ***** Didnt work? ******
Set D_Lat = SummarySheet.Range("B" & NRow)
Set D_Long = SummarySheet.Range("C" & NRow)
' Copy over the values from the source to the destination.
D_Lat.Value = S_Lat.Value
D_Long.Value = S_Long.Value
' Increase NRow so that we know where to copy data next.
NRow = NRow + D_Lat.Rows.Count
' Close the source workbook without saving changes.
WorkBk.Close savechanges:=False
' Use Dir to get the next file name.
FileName = dir()
Loop
' Call AutoFit on the destination sheet so that all
' data is readable.
' SummarySheet.Columns.AutoFit
End Sub
This simple code is not giving you a complete working macro, it will Look for "Latitude" in column A and when found it will transfer the cel.value, and the cel.value below it, to two rows side-by-side in column B and column C on the same worksheet. You will need to wrap it inside your Workbooks.Open loop, modify the Range in the source worksheet to include a last row, include a last row for your new workbook's worksheet and add it to the code inside the If statement. Try to work this into your code and when you encounter problems, you can return to SO and ask a specific question concerning your macro. The macro was tested with actual longitudes and latitudes, in column A, an placed in columns B and C side-by-side.
Dim lRow As Long
lRow = Sheet1.Cells(Rows.Count, 1).End(xlUp).Row
For Each cel In Range("A1:A38")
If InStr(1, cel.Value, "Latitude") Then
x = x + 1
Cells(x, 2).Value = cel.Value
Cells(x, 3).Value = cel.Offset(1).Value
End If
Next cel

Merging a Named Sheet from Multiple Excel Workbooks, copying the headers only once, with a source range that is variable

Below is the code I'm currently trying to run. The code works somewhat but the headers are copied from every worksheet and there is a significant gap in row count between where the data from the next file is copied. For example first file has 3600 row, the next data is copied in row 13,000. Any advice would be greatly appreciated.
Sub MergeAllWorkbooks()
Dim SummarySheet As Worksheet
Dim FolderPath As String
Dim NRow As Long
Dim FileName As String
Dim WorkBk As Workbook
Dim SourceRange As Range
Dim DestRange As Range
Dim LastRow As Long
' Create a new workbook and set a variable to the first sheet.
Set SummarySheet = Workbooks.Add(xlWBATWorksheet).Worksheets(1)
' Modify this folder path to point to the files you want to use.
FolderPath = "C:\Desktop\Files to Combine\"
' NRow keeps track of where to insert new rows in the destination workbook.
NRow = 1
' Call Dir the first time, pointing it to all Excel files in the folder path.
FileName = Dir(FolderPath & "*.xl*")
' Loop until Dir returns an empty string.
Do While FileName <> ""
' Open a workbook in the folder
Set WorkBk = Workbooks.Open(FolderPath & FileName)
' Set the source range to be A1 through BH and the last row.
' Modify this range for workbooks.
LastRow = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row
Set SourceRange = WorkBk.Worksheets(1).Range("A1:BH" & LastRow)
' Set the destination range to start at column A and
' be the same size as the source range.
Set DestRange = SummarySheet.Range("A1" & NRow)
Set DestRange = DestRange.Resize(SourceRange.Rows.Count, _
SourceRange.Columns.Count)
' Copy over the values from the source to the destination.
DestRange.Value = SourceRange.Value
' Increase NRow so that we know where to copy data next.
NRow = NRow + DestRange.Rows.Count
' Close the source workbook without saving changes.
WorkBk.Close savechanges:=False
' Use Dir to get the next file name.
FileName = Dir()
Loop
' Call AutoFit on the destination sheet so that all
' data is readable.
SummarySheet.Columns.AutoFit
End Sub
For row count issue, heed #ScottHoltzman's comments. Another issue too is a large amount of cells can be empty but are still in the used range as only their contents were cleaned but formatting remained. You may need to delete such cells from workbooks not just clear contents.
And to avoid repeat headers, condition the first file to bring over headers and all else to begin on row 2.
i = 1 ' INITIALIZE AN INT/LONG VARIABLE
Do While FileName <> ""
'...
If i = 1 Then
Set SourceRange = WorkBk.Worksheets(1).Range("A1:BH" & LastRow)
Else
Set SourceRange = WorkBk.Worksheets(1).Range("A2:BH" & LastRow)
End If
'...
i = i + 1 ' INCREMENT VARIABLE
FileName = Dir()
Loop

Copy all sheets from multiple workbooks to a single workbook

I have code to select workbooks and to copy just sheet1 of all the workbooks to sheet1 of my Summary work book.
The problem is, I want to copy all the sheets from all the workbooks to my destination workbook.
Note that the sheet names on all the workbooks are identical.
Below is the code that I have.
Private Sub Merge_All_Click()
Dim SummarySheet As Worksheet
Dim FolderPath As String
Dim SelectedFiles() As Variant
Dim NRow As Long
Dim FileName As String
Dim NFile As Long
Dim WorkBk As Workbook
Dim SourceRange As Range
Dim DestRange As Range
Dim LastRow As Long
' Create a new workbook and set a variable to the first sheet.
Set SummarySheet = Workbooks.Add(xlWBATWorksheet).Worksheets(1)
' Modify this folder path to point to the files you want to use.
FolderPath = "C:\Users\ivan.emmanuel\Desktop\My Macro"
' Set the current directory to the the folder path.
ChDrive FolderPath
ChDir FolderPath
' Open the file dialog box and filter on Excel files, allowing multiple files
' to be selected.
SelectedFiles = Application.GetOpenFilename( _
filefilter:="Excel Files (*.xl*), *.xl*", MultiSelect:=True)
' NRow keeps track of where to insert new rows in the destination workbook.
NRow = 1
' Loop through the list of returned file names
For NFile = LBound(SelectedFiles) To UBound(SelectedFiles)
' Set FileName to be the current workbook file name to open.
FileName = SelectedFiles(NFile)
' Open the current workbook.
Set WorkBk = Workbooks.Open(FileName)
' Set the cell in column A to be the file name.
SummarySheet.Range("A" & NRow).Value = FileName
' Set the source range to be A9 through C9.
' Modify this range for your workbooks. It can span multiple rows.
LastRow = WorkBk.Worksheets(1).Cells.Find(What:="*", _
After:=WorkBk.Worksheets(1).Cells.Range("A1"), _
SearchDirection:=xlPrevious, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows).Row
Set SourceRange = WorkBk.Worksheets(1).Range("A1:E" & LastRow)
' Set the destination range to start at column B and be the same size as the source range.
Set DestRange = SummarySheet.Range("B" & NRow)
Set DestRange = DestRange.Resize(SourceRange.Rows.Count, _
SourceRange.Columns.Count)
' Copy over the values from the source to the destination.
DestRange.Value = SourceRange.Value
' Increase NRow so that we know where to copy data next.
NRow = NRow + DestRange.Rows.Count
' Close the source workbook without saving changes.
WorkBk.Close savechanges:=False
Next NFile
' Call AutoFit on the destination sheet so that all data is readable.
SummarySheet.Columns.AutoFit
End Sub
To achieve that, loop all worksheets in Workbook.
Dim SummarySheet As Worksheet
Dim FolderPath As String
Dim SelectedFiles() As Variant
Dim NRow As Long
Dim FileName As String
Dim NFile As Long
Dim WorkBk As Workbook
Dim SourceRange As Range
Dim DestRange As Range
Dim LastRow As Long
Sub merge()
' Create a new workbook and set a variable to the first sheet.
Set SummarySheet = Workbooks.Add(xlWBATWorksheet).Worksheets(1)
' Modify this folder path to point to the files you want to use.
FolderPath = "C:\Users\ivan.emmanuel\Desktop\My Macro"
' Set the current directory to the the folder path.
ChDrive FolderPath
ChDir FolderPath
' Open the file dialog box and filter on Excel files, allowing multiple files
' to be selected.
SelectedFiles = Application.GetOpenFilename( _
filefilter:="Excel Files (*.xl*), *.xl*", MultiSelect:=True)
' NRow keeps track of where to insert new rows in the destination workbook.
NRow = 1
' Loop through the list of returned file names
For NFile = LBound(SelectedFiles) To UBound(SelectedFiles)
' Set FileName to be the current workbook file name to open.
FileName = SelectedFiles(NFile)
' Open the current workbook.
Set WorkBk = Workbooks.Open(FileName)
' Set the cell in column A to be the file name.
SummarySheet.Range("A" & NRow).Value = FileName
' Set the source range to be A9 through C9.
' Modify this range for your workbooks. It can span multiple rows.
LastRow = WorkBk.Worksheets(1).Cells.Find(What:="*", _
After:=WorkBk.Worksheets(1).Cells.Range("A1"), _
SearchDirection:=xlPrevious, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows).Row
Dim ws As Worksheet '---------added to for copy from all worksheets
For Each ws In Workbook '--------
Set SourceRange = ws.Range("A1:E" & LastRow) '------------
' Set the destination range to start at column B and
' be the same size as the source range.
Set DestRange = SummarySheet.Range("B" & NRow)
Set DestRange = DestRange.Resize(SourceRange.Rows.Count, _
SourceRange.Columns.Count)
' Copy over the values from the source to the destination.
DestRange.Value = SourceRange.Value
' Increase NRow so that we know where to copy data next.
NRow = NRow + DestRange.Rows.Count
Next '------------
' Close the source workbook without saving changes.
WorkBk.Close savechanges:=False
Next NFile
' Call AutoFit on the destination sheet so that all data is readable.
SummarySheet.Columns.AutoFit
End Sub

Excel VBA - index and match vba error

I'm very new with VBA and I'm having a problem with the worksheet functions. I'm not sure if I'm using it right as I've been getting a run-time error '1004': Method 'Range' of '_Global' failed. Here's my VBA below hope you guys can help me out. Thanks!
Sub MergeAllWorkbooks2()
Dim FolderPath As String
Dim X As Long
Dim i As Long
Dim FileName As String
Dim WorkBk As Workbook
Dim SourceRange As Range
Dim DestRange As Range
'path of directory
FolderPath = "C:\Users\XXXX\Desktop\New folder\XXXXX\"
' Setting starting points
X = 3
' Call Dir the first time, pointing it to all Excel files in the folder path.
FileName = Dir(FolderPath & "*.xl*")
' Loop until Dir returns an empty string.
Do Until FileName = ""
' Open a workbook in the folder
Set WorkBk = Workbooks.Open(FolderPath & FileName)
'Set the source range
Set SourceRange = WorkBk.Worksheets(1).Range("C2:C7")
' Set the destination range
Workbooks("Summary.xlsm").Worksheets("Sheet1").Activate
Set DestRange = Workbooks("Summary.xlsm").Worksheets("Sheet1").Range(Cells(4, X), Cells(9, X))
' Copy over the values from the source to the destination.
DestRange.Value = SourceRange.Value
'Get hourly from each file
For i = 12 To 8762
Workbooks("Summary.xlsm").Worksheets("Sheet1").Range(Cells(12, X), Range(Cells(12, X).End(xlDown))) = _
Application.WorksheetFunction.Index(WorkBk.Worksheets(2).Range("B3:B8762"), Application.Match(Workbooks("Summary.xlsm").Worksheets("Sheet1").Range(Cells(i, X)), WorkBk.Worksheets(2).Range("A3:A8763")), 0)
Next i
' Increase NColumn so that we know where to copy data next.
X = X + DestRange.Columns.Count
' Close the source workbook without saving changes.
WorkBk.Close savechanges:=False
' Use Dir to get the next file name.
FileName = Dir()
Loop
' Range("C4:C9", Range("C4:C9").End(xlToRight)).Sort key1:=Range("b7"), key2:=Range("b8"), key3:=Range("b9"), _
' order1:=xlAscending, Orientation:=xlLeftToRight
endTime = Now()
totTimeSec = Round(((endTime - startTime) * (24 * CLng(3600))), 1)
MsgBox (totTimeSec & " seconds")
End Sub
I haven't gone through all the code checking for issues, but the main ones were:
You weren't properly qualifying your Range and Cells calls with a
worksheet object;
You can't use Range(cells(x, y)) unless the
value of the cell at Cells(x, y) is the address of a range.
Your parentheses weren't correct in the Index / Match part.
Try this one:
Sub MergeAllWorkbooks2()
Dim FolderPath As String
Dim X As Long
Dim i As Long
Dim FileName As String
Dim WorkBk As Workbook
Dim SourceRange As Range
Dim DestRange As Range
Dim wsDest As Worksheet
'path of directory
FolderPath = "C:\Users\XXXX\Desktop\New folder\XXXXX\"
' Setting starting points
X = 3
' Call Dir the first time, pointing it to all Excel files in the folder path.
FileName = Dir(FolderPath & "*.xl*")
' Loop until Dir returns an empty string.
Do Until FileName = ""
' Open a workbook in the folder
Set WorkBk = Workbooks.Open(FolderPath & FileName)
'Set the source range
Set SourceRange = WorkBk.Worksheets(1).Range("C2:C7")
' Set the destination range
Set wsDest = Workbooks("Summary.xlsm").Worksheets("Sheet1")
Set DestRange = wsDest.Range(wsDest.Cells(4, X), wsDest.Cells(9, X))
' Copy over the values from the source to the destination.
DestRange.Value = SourceRange.Value
'Get hourly from each file
For i = 12 To 8762
wsDest.Range(wsDest.Cells(12, X), wsDest.Cells(12, X).End(xlDown)) = _
Application.WorksheetFunction.Index(WorkBk.Worksheets(2).Range("B3:B8762"), Application.Match(wsDest.Cells(i, X), WorkBk.Worksheets(2).Range("A3:A8763"), 0), 1)
Next i
' Increase NColumn so that we know where to copy data next.
X = X + DestRange.Columns.Count
' Close the source workbook without saving changes.
WorkBk.Close savechanges:=False
' Use Dir to get the next file name.
FileName = Dir()
Loop
' Range("C4:C9", Range("C4:C9").End(xlToRight)).Sort key1:=Range("b7"), key2:=Range("b8"), key3:=Range("b9"), _
' order1:=xlAscending, Orientation:=xlLeftToRight
endTime = Now()
totTimeSec = Round(((endTime - startTime) * (24 * CLng(3600))), 1)
MsgBox (totTimeSec & " seconds")
End Sub

Resources