Set WB = Thisworkbook
Set wk = WB.Sheets("Final")
Set ws = WB.Sheets("OIT-Temp")
irow = wk.Range("B65000").End(xlUp).Row 'Find last row
For i = 2 To irow Step 1
If not wk.Cells(i, 2).FormulaR1C1 = "#N/A" Then
wk.cells(i, 2).copy ws.Cells(i, 2)
wk.cells(i,3).Value = 128
Else
wk.Cells(i, 3).Value = 198
End if
Next i
I'm here facing too much of lag while running this code and unable to understand what's wrong with my code
Please, try the next adapted code. It uses arrays, mostly working in memory and drops the processed arrays at once. That's why it should be very fast:
Sub speedUpCode()
Dim WB As Workbook, wk As Worksheet, ws As Worksheet, iRow As Long, arr, arrCopy, i As Long
Set WB = ThisWorkbook
Set wk = WB.Sheets("Final")
Set ws = WB.Sheets("OIT-Temp")
iRow = wk.Range("B" & wk.rows.count).End(xlUp).row 'Find last row
arr = wk.Range("B2:C" & iRow).Value2 'place the range in an array for faster iteration
arrCopy = ws.Range("B2:B" & iRow).Value2 'place the range in an array for faster iteration
For i = 1 To UBound(arr)
If Not CStr(arr(i, 1)) = "Error 2042" Then ''#N/A
arrCopy(i, 1) = arr(i, 1)
arr(i, 2) = 128
Else
arr(i, 2) = 198
End If
Next i
'drop the processed array values:
wk.Range("B2").Resize(UBound(arr), 2).Value2 = arr
ws.Range("B2").Resize(UBound(arrCopy), 1).Value2 = arrCopy
End Sub
Some general points:
Indent your code.
Give your variables meaningful names.
Normal to write positive code block in if/else first.
I'm not sure how you're doing an xlUp on an entire row.
For this specific problem, reading and writing cells is computationally expensive. You can remove a lot of this by reading and writing data in bulk and working with your data in arrays in memory.
Try this and see if it speeds things up.
Sub FastReadWrite()
' Set the range references.
With ThisWorkbook
With .Sheets("Final")
Dim maxRow As Long
maxRow = .Range("B65000").End(xlUp).Row
Dim finalData As Range
Set finalData = .Range("B2:C" & maxRow)
End With
Dim oitTemData As Range
Set oitTemData = .Sheets("OIT-Temp") _
.Range("B2:C" & maxRow)
End With
' Read the data from the ranges into memory.
Dim fArray() As Variant: fArray = finalData.Formula2R1C1
Dim tArray() As Variant: tArray = oitTemData.Formula2R1C1
' Main logic loop.
Dim i As Long
For i = 1 To UBound(fArray, 1)
If fArray(i, 1) = "#N/A" Then
fArray(i, 2) = 198
Else
tArray(i, 1) = fArray(i, 1)
fArray(i, 2) = 128
End If
Next i
' Write the data to the ranges.
finalData.Formula2R1C1 = fArray
oitTemData.Formula2R1C1 = tArray
End Sub
Related
I use the code hereunder to calculate max values as described in this post (vba max value of group of values). The code works great but once I have more than 65k lines I get a data type mismatch when trying to pase the array:
sht.Range(Cells(1, lColumn), Cells(last.Row, lColumn)).Value = Application.Index(groupsArray, , lColumn)
Could somebody help me to slice the array in chunks. I have tried to get it working myself but without any luck.
Sub FillGroupsMax()
Dim lColumn As Long
Dim sht As Worksheet
Dim groupsArray As Variant 'array with all group infomation
Dim groupsSeen As Variant 'array with group infomation already seen
Application.ScreenUpdating = False 'stop screen updating makes vba perform better
Set sht = ThisWorkbook.Worksheets("import")
Set last = sht.Range("A:A").Find("*", Cells(1, 1), searchdirection:=xlPrevious) 'last cell with value in column A
lColumn = sht.Cells(1, Columns.Count).End(xlToLeft).Column
groupsArray = sht.Range(Cells(1, 1), Cells(last.Row, lColumn))
'collect all the information on the Sheet into an array
'Improves performance by not visiting the sheet
For dRow = 2 To last.Row 'for each of the rows skipping header
'check if group as already been seen
If inArrayValue(Cells(dRow, 1).Value, groupsSeen) > 0 Then
'if it has been seen/calculated attribute value
'Cells(dRow, 4).Value = inArrayValue(Cells(dRow, 1).Value, groupsSeen)
groupsArray(dRow, lColumn) = inArrayValue(Cells(dRow, 1).Value, groupsSeen)
Else
'if it hasn't been seen then find max
'Cells(dRow, 4).Value = getMax(Cells(dRow, 1).Value, groupsArray)
groupsArray(dRow, lColumn) = getMax(Cells(dRow, 1).Value, groupsArray, lColumn)
'array construction from empty
If IsEmpty(groupsSeen) Then
ReDim groupsSeen(0)
'groupsSeen(0) = Array(Cells(dRow, 1).Value, Cells(dRow, 4).Value)
groupsSeen(0) = Array(groupsArray(dRow, 1), groupsArray(dRow, lColumn))
'attribute value to array
Else
ReDim Preserve groupsSeen(0 To UBound(groupsSeen) + 1)
groupsSeen(UBound(groupsSeen)) = Array(groupsArray(dRow, 1), groupsArray(dRow, lColumn))
End If
End If
Next
sht.Range(Cells(1, lColumn), Cells(last.Row, lColumn)).Value = Application.Index(groupsArray, , lColumn)
'reactivate Screen updating
Application.ScreenUpdating = True
End Sub
Function getMax(group As String, groupsArray As Variant, lColumn As Long) As Double
'for each in array
For n = 1 To UBound(groupsArray)
'if its the same group the Max we seen so far the record
If groupsArray(n, 1) = group And groupsArray(n, lColumn - 1) > maxSoFar Then
maxSoFar = groupsArray(n, lColumn - 1)
End If
Next
'set function value
getMax = maxSoFar
End Function
Function inArrayValue(group As String, groupsSeen As Variant) As Double
'set function value
inArrayValue = 0
'if array is empty then exit
If IsEmpty(groupsSeen) Then Exit Function
'for each in array
For n = 0 To UBound(groupsSeen)
'if we find the group
If groupsSeen(n)(0) = group Then
'set function value to the Max value already seen
inArrayValue = groupsSeen(n)(1)
'exit function earlier
Exit Function
End If
Next
End Function
You can write a helper function to use instead of Application.Index
Bonus - it will be much faster than using Index (>5x)
Sub Tester()
Dim arr, arrCol
arr = Range("A2:J80000").Value
arrCol = GetColumn(arr, 5) '<< get the fifth column
Range("L2").Resize(UBound(arrCol, 1), 1).Value = arrCol
End Sub
'extract a single column from a 1-based 2-D array
Function GetColumn(arr, colNumber)
Dim arrRet, i As Long
ReDim arrRet(1 To UBound(arr, 1), 1 To 1)
For i = 1 To UBound(arr, 1)
arrRet(i, 1) = arr(i, colNumber)
Next i
GetColumn = arrRet
End Function
EDIT - since QHarr asked about timing here's a basic example
Sub Tester()
Dim arr, arrCol, t, i as long
arr = Range("A2:J80000").Value
t = Timer
For i = 1 to 100
arrCol = GetColumn(arr, 5) '<< get the fifth column
Next i
Debug.print Timer - t '<<# of seconds for execution
End Sub
Below, whilst not as tidy as could be, is a way to process an array in chunks and Index to access a column and write out to the sheet.
I populated two columns (A:B) with data. Both had 132,000 rows, populated incrementally, with values from 1 to 132,000 in each column for my test run.
You can fiddle with cutOff to get the chunk size just below the point where the fail happens.
The code below is simply to demonstrate the principle of looping in batches, upto the set cutoff in each batch, until all rows have been processed.
Option Explicit
Public Sub WriteArrayToSheet()
Dim wb As Workbook
Dim ws As Worksheet
Set wb = ThisWorkbook
Set sht = wb.Worksheets("Sheet1") 'change as appropriate
Dim myArr() 'dynamic array
myArr = sht.Range("A1").CurrentRegion.Value 'you may want a more robust method
Dim cutOff As Long 'the max value - what ever it is before error occurs
cutOff = 1000
Dim totalRows As Long 'total rows in array read in from sheet
totalRows = UBound(myArr, 1)
Dim totalArraysNeeded As Long
'Determine how many lots of cutOff chunks there are in the total number of array rows
totalArraysNeeded = Application.WorksheetFunction.Ceiling(totalRows / cutOff, 1)
Dim rotations As Long 'number of times to loop original array to handle all rows
Dim rowCountTotal As Long
Dim rowCount As Long
Dim tempArr() 'this will hold the chunk of the original array
Dim rowCounter As Long
Dim lastRow As Long
Dim nextRow As Long
Dim i As Long
Dim j As Long
Dim numRows As Long
rotations = 1
Do While rotations < totalArraysNeeded
If rotations < totalArraysNeeded - 1 Then
ReDim tempArr(1 To cutOff, 1 To UBound(myArr, 2)) 'size chunk array
numRows = cutOff
Else
numRows = totalRows - rowCountTotal
ReDim tempArr(1 To numRows, 1 To UBound(myArr, 2)) 'size chunk array
End If
For i = 1 To numRows
rowCount = 1 'rows in this chunk looped
rowCountTotal = rowCountTotal + 1 'rows in original array looped
For j = LBound(myArr, 2) To UBound(myArr, 2)
tempArr(i, j) = myArr(rowCountTotal, j)
Next j
rowCount = rowCount + 1
Next i
With sht
lastRow = .Cells(.Rows.Count, "E").End(xlUp).Row 'Column where I am writing the sliced column out to
End With
If lastRow = 1 Then
nextRow = 1
Else
nextRow = lastRow + 1
End If
sht.Range("E" & nextRow).Resize(UBound(tempArr, 1), 1) = Application.Index(tempArr, , 1) 'write out to sheet
rotations = rotations + 1
Loop
End Sub
As #Tim suggested, the best way to slice a large array is use a loop to copy the column.
Though in your case, most of the processing time is spent on computing the maximum since your code is using a nested loop.
If you want to reduce significantly the processing time, then use a dictionary:
Sub Usage
GetMaxByGroupTo _
sourceGroups := ThisWorkbook.Range("Sheet1!A2:A100"), _
sourceValues := ThisWorkbook.Range("Sheet1!B2:B100"), _
target := ThisWorkbook.Range("Sheet1!C2")
End Sub
Sub GetMaxByGroupTo(sourceGroups As Range, sourceValues As Range, target As Range)
Dim dict As Object, groups(), values(), r As Long, max
Set dict = CreateObject("Scripting.Dictionary")
groups = sourceGroups.Value2
values = sourceValues.Value2
' store the maximum value of each group in a dictionary for an efficient lookup '
For r = Lbound(groups) to Ubound(groups)
max = dict(groups(r, 1))
If VarType(max) And values(r, 1) <= max Then Else dict(groups(r, 1)) = values(r, 1)
Next
' build and copy the result array to the sheet '
For r = Lbound(groups) to Ubound(groups)
values(r, 1) = dict(groups(r, 1))
Next
target.Resize(Ubound(groups), 1).Value2 = values
End Sub
ws1lastrow value in the code below is 147583
I am executing the code below from within the VB Editor. Debug.print is used to keep a track of rows processed. ws1lastrow value is 147583
After executing till 5000 or 6000 (every time the count changes), the Excel stops responding and I have to restart and run.
Any reason why this happens and any solutions/tips for handling this?
Sub IdentifyMissingsNew()
Dim ws1 As Worksheet
Dim rws As Worksheet
Set ws1 = ThisWorkbook.Sheets("New")
Set rws = ThisWorkbook.Sheets("DelInt")
ws1lastrow = ws1.Cells(Rows.Count, 1).End(xlUp).Row
Set lookuprange = rws.Range("a1").CurrentRegion
For i = 2 To ws1lastrow
ws1.Cells(i, "ae") = Application.VLookup(ws1.Cells(i, "a"), lookuprange, 3, False)
Debug.Print i
Next i
End Sub
In a quick test this completed a lookup of 200k rows against a table of 100k values in just less than 3 sec.
It's a bit more complex than your original code, but if you want to optimize for speed that's sometimes unavoidable.
Notes:
use a scripting dictionary as a lookup
read/write all values as arrays for maximum speed
Code:
Sub IdentifyMissingsNew()
Dim ws1 As Worksheet
Dim rws As Worksheet, t, arr1, arr2
Dim dict As Object, rw As Range, res(), arr, nR As Long, i As Long
Set ws1 = ThisWorkbook.Sheets("New")
Set rws = ThisWorkbook.Sheets("DelInt")
Set dict = CreateObject("scripting.dictionary")
t = Timer
'create a lookup from two arrays
arr1 = rws.Range("a1").CurrentRegion.Columns(1).Value
arr2 = rws.Range("a1").CurrentRegion.Columns(3).Value
For i = 2 To UBound(arr1, 1)
dict(arr1(i, 1)) = arr2(i, 1)
Next i
Debug.Print "created lookup", Timer - t
'get the values to look up
arr = ws1.Range(ws1.Range("A2"), ws1.Cells(Rows.Count, 1).End(xlUp))
nR = UBound(arr, 1) '<<number of "rows" in your dataset
ReDim res(1 To nR, 1 To 1) '<< resize the output array to match
'perform the lookup
For i = 1 To nR
If dict.exists(arr(i, 1)) Then
res(i, 1) = dict(arr(i, 1))
Else
res(i, 1) = "No match!"
End If
Next i
ws1.Range("AE2").Resize(nR, 1).Value = res '<< populate the results
Debug.Print "Done", Timer - t
End Sub
I would like to export data from a consolidated sheet (DATA) to multiple sheets regarding criteria.
I have a total of 13 criteria, each criteria has to be exported in its dedicated sheet.
I'm trying to optimize this macro (only 2 criteria here) because it lag out
Sub copy()
Application.ScreenUpdating = False
Dim i As Long
Dim j As Long
Dim sh As Worksheet
Dim feuillePrincipale As Worksheet
Dim S01Sheet As Worksheet
Dim S02Sheet As Worksheet
Set feuillePrincipale = ThisWorkbook.Sheets("DATA")
Set S01Sheet = ThisWorkbook.Sheets("S01")
Set S02Sheet = ThisWorkbook.Sheets("S02")
For Each sh In ThisWorkbook.Worksheets
If sh.Name = "S01" Then
i = 2
j = 2
While Not IsEmpty(feuillePrincipale.Cells(i, 1))
If feuillePrincipale.Cells(i, 11).Value Like "S01*" Then
feuillePrincipale.Cells.Rows(i).EntireRow.copy S01Sheet.Rows(j)
j = j + 1
End If
i = i + 1
Wend
End If
If sh.Name = "S02" Then
i = 2
j = 2
While Not IsEmpty(feuillePrincipale.Cells(i, 1))
If feuillePrincipale.Cells(i, 11).Value Like "S02*" Then
feuillePrincipale.Cells.Rows(i).EntireRow.copy S02Sheet.Rows(j)
j = j + 1
End If
i = i + 1
Wend
End If
Next
Application.ScreenUpdating = True
End Sub
If you have any idea, I read I can use Advanced filter but as you guess I'm new in VBA so I'm listening any tips!
Here is the Advanced Filter method you asked for:
Public Sub Christophe()
Const FILTER_COLUMN = 11
Dim i&, rCrit As Range, rData As Range, aShts
aShts = ["SO"&row(1:13)]
Set rData = Sheets("DATA").[a1].CurrentRegion
Set rCrit = rData.Resize(2, 1).Offset(, rData.Columns.Count + 2)
rCrit(1) = rData(1, FILTER_COLUMN)
For i = 1 To UBound(aShts)
rCrit(2) = aShts(i, 1) & "*"
rData.AdvancedFilter xlFilterCopy, rCrit, Sheets(aShts(i, 1)).[a1].Resize(, rData.Columns.Count)
Next
rCrit.Clear
End Sub
The execution time should be instantaneous.
Note: this assumes that you do have 13 criteria, each starting with "SO" and that they occupy column 11 of the Data sheet. It also assumes that you already have 13 sheets named SO1... SO13 in the workbook.
UPDATE
Based on new information that the pattern of the criteria can change, please try this version instead. Note, that it assumes that the sheets already exist and that the sheet names match the criteria:
Public Sub Christophe()
Const FILTER_COLUMN = 11
Dim i&, rCrit As Range, rData As Range, aShts
aShts = Array("SO1", "SO2", "ADQ03", "LocS10")
Set rData = Sheets("DATA").[a1].CurrentRegion
Set rCrit = rData.Resize(2, 1).Offset(, rData.Columns.Count + 2)
rCrit(1) = rData(1, FILTER_COLUMN)
For i = 0 To UBound(aShts)
rCrit(2) = aShts(i) & "*"
rData.AdvancedFilter xlFilterCopy, rCrit, Sheets(aShts(i)).[a1].Resize(, rData.Columns.Count)
Next
rCrit.Clear
End Sub
Try using an array to set your criteria sheets:
Dim shArray As Variant
Dim shArrayString As String
Dim feuillePrincipale As Excel.Worksheet
Dim i As Long
Dim j As Long
Set feuillePrincipale = ThisWorkbook.Sheets("DATA")
j = 1
'// Create array and populate
shArray = Array("S01", "S02", "S03", "S04") '// add as required
'// Create string representation of array
shArrayString = "{"""
For i = LBound(shArray) To UBound(shArray)
shArrayString = shArrayString & shArray(i) & ""","""
Next
shArrayString = Left(shArrayString, Len(shArrayString) - 2) & "}"
'//Start loop
With feuillePrincipale
For i = 2 To .Cells(.Rows.Count, 1).End(xlUp).Row
If Not Evaluate("ISERROR(MATCH(" & Left(.Cells(i, 11), 3) & "," & shArrayString & ",0))") Then
.Rows(i).Copy Sheets(shArray(WorksheetFunction.Match(Left(.Cells(i, 11), 3), shArray, 0))).Cells(j, 1)
j = j + 1
End If
Next
End With
It's a bit unclear because if you follow the code you've posted - it's actually just copying and pasting data to the same sheet...
Yes, you should use an autofilter and use a special select to get only the visible cells.
If you want the loop method, you should loop through each row on sheets("DATA") and use a Select Case Statement to decide onto which sheet the data is placed.
By looping through each sheet you are adding loops that will slow it down.
Application.ScreenUpdating = False
Dim i As Long
Dim j As Long
Dim cel As Range
Dim sh As Worksheet
Dim feuillePrincipale As Worksheet
Dim S01Sheet As Worksheet
Dim S02Sheet As Worksheet
Set feuillePrincipale = ThisWorkbook.Sheets("DATA")
Set S01Sheet = ThisWorkbook.Sheets("S01")
Set S02Sheet = ThisWorkbook.Sheets("S02")
For Each cel In feuillePrincipale.Range(feuillePrincipale.Range("A1"), feuillePrincipale.Range("A1").End(xlDown))
Select Case Left(cel.offset(,10).value, 3)
Case "S01"
j = S01Sheet.Range("A" & Rows.count).End(xlUp).Offset(1).Row
feuillePrincipale.Cells.Rows(cel.Row).EntireRow.copy S01Sheet.Rows(j)
Case "S02"
j = S02Sheet.Range("A" & Rows.count).End(xlUp).Offset(1).Row
feuillePrincipale.Cells.Rows(cel.Row).EntireRow.copy S02Sheet.Rows(j)
'Case .... keep adding select statement till you get to the last condition
Case Else
End Select
Next cel
Application.ScreenUpdating = True
Does it exist any way to make this code run faster as it goes one row by one row ?
Sub cut_good_row_range_from_sh2_to_sh1()
Application.ScreenUpdating = False
For i = 2 To Sheets("sheet1").Cells(Rows.Count, "A").End(xlUp).Row
For j = 2 To Sheets("sheet2").Cells(Rows.Count, "A").End(xlUp).Row
'Caution: I want to cut BB:BD, so I select BA:BD !
If Sheets("sheet1").Range("A" & i).Value = Sheets("sheet2").Range("A" & j).Value Then
Sheets("sheet2").Range("BA" & j & ":BS" & j).Cut Sheets("sheet1").Range("BA" & i & ":BS" & i)
End If
Next j
Next i
Application.ScreenUpdating = True
End Sub
Thanks ;)
It has been demonstrated on SO many times that looping over ranges is slow, and looping over variant arrays is much faster.
The 'best' method depends on the specifics of the use case. Making as few assumptions as I can, this demo shows how effective it can be. The assumptions made are
Data only is required, Format is not transfered.
No Formulas exist in the Destination range (If they do, they will be overwritten with their current value)
This is a simplistic example, further optimisations can be made.
Sub Demo()
Dim Found As Boolean
Dim i As Long, j As Long, k As Long
Dim rSrcA As Range, rSrc As Range
Dim vSrcA As Variant, vSrc As Variant
Dim rDstA As Range, rDst As Range
Dim vDstA As Variant, vDst As Variant
Dim rClear As Range
' Get references to Source Data Range and Variant Array
With Worksheets("Sheet2")
Set rSrcA = Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp))
vSrcA = rSrcA.Value
Set rSrc = .Range("BA1:BS1").Resize(UBound(vSrcA, 1))
vSrc = rSrc
End With
' Get references to Destination Data Range and Variant Array
With Worksheets("Sheet1")
Set rDstA = Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp))
vDstA = rDstA.Value
Set rDst = .Range("BA1:BS1").Resize(UBound(vDstA, 1))
vDst = rDst
End With
' Loop Source
For i = 1 To UBound(vSrcA, 1)
' Loop Destination
For j = 1 To UBound(vDstA, 1)
' Compare
If vSrcA(i, 1) = vDstA(j, 1) Then
Found = True
' Update Destination Data Array, to be copied back to sheet later
For k = 1 To UBound(vSrc, 2)
vDst(j, k) = vSrc(i, k)
Next
End If
Next
' If match found, track Source range to clear later
If Found Then
If rClear Is Nothing Then
Set rClear = rSrc.Rows(i)
Else
Set rClear = Union(rClear, rSrc.Rows(i))
End If
Found = False
End If
Next
' Update Destination Range
rDst.Value = vDst
' Clear Source Range
rClear.ClearContents
End Sub
When run on a test data set of 15 source rows and 200 destination rows, this reduced execution time from about 17s to about 10ms
I have many, over two dozen (and counting), data sets with 15000 rows and 36 columns each, that I would like to combine. These data sets are have the same columns and more or less the same rows. They are monthly snapshots of the same data, with some data leaving and some entering (hence the marginally different number of rows.
I would like the user to select some of them and and combine them. The name of the file contains that date and my code extracts the date and adds it in a new column at the end. Right now, my code works. I collect all the data in a three dimensional array and then paste it in a new workbook. The problem is that since each book has different numbers or rows, I am creating a data array with more rows than needed. So my data has a lot of empy rows right now. I guess I can delete the empty rows in the end. I am new to excel VBA and new to doing data work so I was wondering if there was a smarter, more efficient way of construction my panel.
Dim DataArray As Variant
Sub test()
Dim filespec As Variant, i As Integer
ReDim DataArray(0 To 20000, 0 To 36, 0 To 0)
' Here the user gets to select the files
On Error GoTo EndNow
filespec = Application.GetOpenFilename(FileFilter:="microsoft excel files (*.xls), *.xls", Title:="Get File", MultiSelect:=True)
For i = 1 To UBound(filespec)
ReDim Preserve DataArray(0 To 20000, 0 To 36, 0 To i)
Set wbSource = Workbooks.Open(filespec(i))
Set ws1 = wbSource.Worksheets("Sheet1")
With ws1
'now I store the values in my array
FinalColumn = .Cells(1, .Columns.Count).End(xlToLeft).Column
FinalRow = .Range("B" & .Rows.Count).End(xlUp).Row
For j = 1 To FinalRow
For k = 1 To FinalColumn
DataArray(j, k, i) = .Cells(j, k).Value
Next k
' Now I extract the date data from the file name and store it in the last column of my array.
DataArray(j, FinalColumn + 1, i) = piece(piece(GetFileName(CStr(filespec(i))), "_", 3), ".", 1)
Next j
End With
ActiveWorkbook.Close
Next i
Set wb2 = Application.Workbooks.Add
Set ws2 = wb2.Worksheets("Sheet1")
With ws2
For i = 1 To UBound(DataArray, 3)
FinalRow2 = 20000
FinalColumn2 = 36
For k = 1 To FinalColumn2
' I did this If loop so as to not copy headers every time.
If i = 1 Then
For j = 1 To FinalRow2
.Cells(j, k).Value = DataArray(j, k, i)
Next j
Else
For j = 2 To FinalRow2
.Cells(FinalRow2 * (i - 1) + j, k).Value = DataArray(j, k, i)
Next j
End If
Next k
Next i
wb2.Sheets(1).Name = "FolderDetails Panel Data"
wb2.SaveAs ThisWorkbook.Path & "Folder_Details_Panel_Data" & "_" & Format(Date, "yyyy_mm_dd"), _
FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
End With
EndNow:
End Sub
' MsgBox GetFileName(filespec(0))
Function GetFileName(filespec As String)
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
GetFileName = fso.GetFileName(filespec)
End Function
Function piece(Searchstring As String, Separator As String, IndexNum As Integer) As String
Dim t
t = Split(Searchstring, Separator)
If UBound(t) > 0 Then piece = t(IndexNum - 1)
End Function
To answer your direct question, I would copy the data from each workbook into the merged workbook as each is processed. I see no advantage in collecting all the data into a 3D array.
There are also many other issues with your code. What follows is a refactor of your code, with changes highlighted.
Option Explicit ' <-- Force declaration of all variables (must be first line in module)
Sub Demo()
Dim filespec As Variant
Dim i As Long ' --> Long is prefered over Integer
Dim DataArray As Variant ' <-- no need to be Module scoped
' --> Declare all your variables
Dim j As Long, k As Long
Dim wbSource As Workbook
Dim ws As Worksheet
Dim wbMerged As Workbook
Dim wsMerged As Worksheet
Dim DataHeader As Variant
Dim FinalRow As Long, FinalColumn As Long
Dim sDate As String
Dim rng As Range
' Here the user gets to select the files
On Error GoTo EndNow
filespec = Application.GetOpenFilename(FileFilter:="microsoft excel files (*.xls), *.xls", Title:="Get File", MultiSelect:=True)
If Not IsArray(filespec) Then
' <-- User canceled
Exit Sub
End If
' Speed up processing <--
' -- Comment these out for debugging purposes
'Application.ScreenUpdating = False
'Application.Calculation = xlCalculationManual
' Create Merged Workbook
Set wbMerged = Application.Workbooks.Add
Set wsMerged = wbMerged.Sheets(1)
wsMerged.Name = "FolderDetails Panel Data"
For i = 1 To UBound(filespec)
Set wbSource = Workbooks.Open(filespec(i))
Set ws = wbSource.Worksheets("Sheet1")
With ws
FinalColumn = .Cells(1, .Columns.Count).End(xlToLeft).Column
FinalRow = .Cells(.Rows.Count, 2).End(xlUp).Row
If i = 1 Then
' Get header from first workbook only
DataHeader = Range(.Cells(1, 1), .Cells(1, FinalColumn)).Value ' <-- Get data header
ReDim Preserve DataHeader(1 To 1, 1 To UBound(DataHeader, 2) + 1) ' <-- Range.Value arrays are 1 based
k = UBound(DataHeader, 2)
DataHeader(1, k) = "Date" ' <-- Header
End If
' Get all data in one go, excluding header
DataArray = Range(.Cells(2, 1), .Cells(FinalRow, FinalColumn)).Value ' <-- Array size matches data size
End With
wbSource.Close False
' Add Date to data
sDate = GetDateFromFileName(filespec(i)) '<-- do it once
' resize data array
ReDim Preserve DataArray(1 To UBound(DataArray, 1), 1 To UBound(DataArray, 2) + 1) ' <-- Range.Value arrays are 1 based
' Add date data
For j = 1 To UBound(DataArray, 1)
DataArray(j, k) = sDate
Next j
' Complete processing of each workbook as its opened
With wsMerged
' Add header row from first workbook
If i = 1 Then
Range(.Cells(1, 1), .Cells(1, UBound(DataArray, 2))) = DataHeader
End If
' <-- Add data to end of sheet
' Size the destination range to match the data
Set rng = .Cells(.Rows.Count, 2).End(xlUp).Offset(1, -1)
Set rng = rng.Resize(UBound(DataArray, 1), UBound(DataArray, 2))
rng = DataArray
End With
Next i
' <-- append \ to path
wbMerged.SaveAs ThisWorkbook.Path & "\" & "Folder_Details_Panel_Data" & "_" & Format(Date, "yyyy_mm_dd"), _
FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
CleanUp:
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Exit Sub
EndNow:
MsgBox "Oh dear"
GoTo CleanUp
End Sub
' Simplified
' <-- Not entirely sure if this will match your file name pattern.
' Please check
' Assumed file name
' Some\Path\Some_Words_YYYMMDD.xls
Function GetDateFromFileName(Nm As Variant) As String
Dim str As String
str = Mid$(Nm, InStrRev(Nm, "\") + 1)
str = Left$(str, InStrRev(str, ".") - 1)
str = Mid$(str, InStrRev(str, "_") + 1)
GetDateFromFileName = str
End Function