EXCEL VBA: My macro is creating a 3D dimension array - arrays

I have lots of recruitment data that i want to re-arrange, separate and modify using arrays. The data includes all information from 1st stage, 2nd stage and 3rd stage interview for each candidates. The idea is to separate each stage onto their own sheets (e.g. Interview 1, interview 2, interview 3). And then to also create a table that has information from all three stages for each candidate.
Firstly, i have created an array of all the data by declaring the range ("A1:AV10000") as a variant.
Then i have created a loop to loop through this data, and separate each type of event that occurs into their own arrays, using an IF function within the loop. If condition is met, create a new array and add each row that condition is met to an array.
However, i believe my arrays are being made into a 3D array and i am sure how to edit the code so that it remains 2Darray. I understand why the code may be creating 3D array (due to iterating by 1 in the loop), however i am unsure how to write code so it includes all data the row and only iterates as shown below.
e.g. currently it goes (1)(1,1),(1)(1,2) then (2)(1,1),(2)(1,2) then (3)(1,1),(3)(1,2).
I would think it would work if it was (1,1)(1,2) then (2,1)(2,2) then (3,1)(3,2). Screenshot of array format from local window
Sub AddProcessStageToArray(SourceWorksheet, RawDataArray, LastrowData, WhatStage, ArrayOutput)
For i = LBound(RawDataArray) To UBound(RawDataArray)
If RawDataArray(i, 13) = WhatStage And RawDataArray(i, 38) <> "NOK" Then
o = o + 1
'Dim ArrayName() As Variant
ReDim Preserve ArrayOutput(o)
ArrayOutput(o) = Application.Index(SourceWorksheet.Range("A1:AO" & LastrowData), i, 0)
End If
Next
End Sub
The code is being called as shown below.
Sub AddITWToArray()
Dim DataWs As Worksheet: Set DataWs = ThisWorkbook.Sheets("DATA")
Dim PoolOfWeekWs As Worksheet: Set PoolOfWeekWs = ThisWorkbook.Sheets("Pool of the week")
Dim LastrowData As Long: LastrowData = DataWs.Range("A" & Rows.Count).End(xlUp).Row
Dim LastColData As Long: LastColData = DataWs.Cells(1 & DataWs.Columns.Count).End(xlToLeft).Column
Dim LastColDataString As String: LastColDataString = Split(Cells(1, LastColData).Address, "$")(1)
Dim DataRange As Range: Set DataRange = DataWs.Range("A1:" & LastColDataString & LastrowData)
Dim DataArr As Variant: DataArr = DataWs.Range("A1:AO" & LastrowData)
'Loop through Data array, if interview process = PQL, add to table. If interview proces = 1sTITW find postion and add data, if 2ndITW find postion and highlight, if 3rd find postion and highlight
Dim PoolofWeekTableLRow As Long: PoolofWeekTableLRow = PoolOfWeekWs.Range("A" & Rows.Count).End(xlUp).Row
'PoolOfWeekWs.Rows("3:" & PoolofWeekTableLRow).ClearContents
Dim i, o As Long
Dim RowNumberArr As Variant
'Create PQLArray
Dim PQLArray() As Variant
Call AddProcessStageToArray(DataWs, DataArr, LastrowData, "Prequalification", PQLArray)
'Create 1ITWArray
Dim FirstITWArray() As Variant
Call AddProcessStageToArray(DataWs, DataArr, LastrowData, "Candidate Interview 1", FirstITWArray)
'Create 2ITWArray
Dim SecondITWArray() As Variant
Call AddProcessStageToArray(DataWs, DataArr, LastrowData, "Candidate Interview 2+", SecondITWArray)
'Create PPLArray
Dim PPLArray() As Variant
Call AddProcessStageToArray(DataWs, DataArr, LastrowData, "Candidate Interview 2*", PPLArray)

Try the next adapted function, please:
Function AddProcessStageToArray(SourceWorksheet As Worksheet, RawDataArray, LastrowData As Long, WhatStage As String) As Variant
Dim ArrayOutput() As Variant, o As Long, i As Long, j As Long
ReDim ArrayOutput(1 To UBound(RawDataArray, 2), 1 To UBound(RawDataArray, 2))
For i = LBound(RawDataArray) To UBound(RawDataArray)
If RawDataArray(i, 13) = WhatStage And RawDataArray(i, 38) <> "NOK" Then
o = o + 1
For j = 1 To UBound(RawDataArray, 2)
ArrayOutput(j, o) = RawDataArray(i, j)
Next j
End If
Next
ReDim Preserve ArrayOutput(1 To UBound(RawDataArray, 2), 1 To o)
AddProcessStageToArray = WorksheetFunction.Transpose(ArrayOutput)
End Function
It can be called in this way:
Sub testAddProcessStToArr()
Dim DataWs As Worksheet, DataArr As Variant, LastrowData As Long
Set DataWs = ThisWorkbook.Sheets("DATA")
LastrowData = DataWs.Range("A" & rows.count).End(xlUp).row
DataArr = DataWs.Range("A1:AO" & LastrowData)
Dim PQLArray() As Variant
PQLArray = AddProcessStageToArray(DataWs, DataArr, LastrowData, "Prequalification")
Dim NewSheet as Worksheet
Set NewSheet = ActiveWorkbook.Sheets.Add
NewSheet.Range("A1").Resize(UBound(PQLArray), UBound(PQLArray, 2)).Value = PQLArray
End Sub
Edited:
Please, also try the next approach, involving a preliminary counting of rows respecting the conditions criteria and then use them to fill the final array. The adapted function to be used will be the next:
Function AddProcessStageToArr(RawDataArray, arrNo As Variant) As Variant
Dim ArrayOutput() As Variant, o As Long, i As Long, j As Long
ReDim ArrayOutput(1 To UBound(arrNo) + 1, 1 To UBound(RawDataArray, 2))
For i = 0 To UBound(arrNo)
o = o + 1
For j = 1 To UBound(RawDataArray, 2)
ArrayOutput(o, j) = RawDataArray(arrNo(i), j)
Next j
Next
AddProcessStageToArr = ArrayOutput
End Function
The above function should be called in the next way:
Sub testAddProcessStToArrBis()
Dim DataWs As Worksheet, DataArr As Variant, LastrowData As Long
Dim arrNo As Variant, i As Long, k As Long
Set DataWs = ActiveSheet
LastrowData = DataWs.Range("A" & rows.count).End(xlUp).row
DataArr = DataWs.Range("A1:AO" & LastrowData).Value
ReDim arrNo(UBound(DataArr))
For i = 1 To UBound(DataArr)
If DataArr(i, 13) = "Prequalification" And DataArr(i, 38) <> "NOK" Then
arrNo(k) = i: k = k + 1
End If
Next i
ReDim Preserve arrNo(k - 1)
Dim PQLArray() As Variant
PQLArray = AddProcessStageToArr(DataArr, arrNo)
Dim NewSheet As Worksheet
Set NewSheet = ActiveWorkbook.Sheets.Add(After:=DataWs)
NewSheet.Range("A1").Resize(UBound(PQLArray), UBound(PQLArray, 2)).Value = PQLArray
End Sub
The same function must be used, but changing "Prequalification" with "Candidate Interview x" and rebuild arrNo for each case...

Related

printing array only resulting in first value being printed into excel?

Assigning word document lines of text to an array to then print into an excel column. I want to print each item in array to it's own cell.
Currently, all the items are storying correctly into the array, but it's only printing the first item over and over Action
Code:
Option Explicit
Sub ParaCopy()
Dim wApp As Word.Application
Dim wDoc As Word.Document
Set wApp = CreateObject("Word.Application")
Set wDoc = wApp.Documents.Open("J:\Data Dictionary.docx", ReadOnly:=True)
Dim wPara As Word.Paragraph
Dim arr() As Variant
Dim i As Long
i = 0
For Each wPara In wDoc.Paragraphs
If wPara.Range.Words.Count > 1 Then
ReDim Preserve arr(i)
arr(i) = wPara.Range
End If
i = i + 1
Next wPara
For i = LBound(arr) To UBound(arr)
[a1].Resize(UBound(arr) + 1) = arr
Next i
End Sub
EDIT: Need to separate each block of text separated by a space (outlined in blue) to this
Create a 2D array with one column and load that:
Option Explicit
Sub ParaCopy()
Dim wApp As Word.Application
Dim wDoc As Word.Document
Set wApp = CreateObject("Word.Application")
Set wDoc = wApp.Documents.Open("J:\Data Dictionary.docx", ReadOnly:=True)
Dim wPara As Word.Paragraph
Dim arr() As Variant
ReDim arr(1 To wDoc.Paragraphs.Count, 1 To 1)
Dim i As Long
i = 1
For Each wPara In wDoc.Paragraphs
If wPara.Range.Words.Count > 1 Then
arr(i, 1) = wPara.Range
i = i + 1
End If
Next wPara
[a1].Resize(UBound(arr) + 1) = arr
End Sub
Copy Word Paragraphs to Excel Cells Using an Array
The number of rows of the array is wDoc.Paragraphs.Count which may differ from r (the 'actual count') hence you have to use r with Resize, and not wDoc.Paragraphs.Count or UBound(Data, 1).
Don't forget to Close the Document and Quit the App.
The first solution is early-bound and needs the library reference. When using it, just use
Set wApp = New Word.Application.
The second solution is late-bound and doesn't need the library reference. Also, it has been 'stripped off' the document and application variables (not necessary, you can declare them As Object).
Option Explicit
' e.g. Tools>References>Microsoft Word 16.0 Object Library
Sub ParaCopy()
Const FilePath As String = "J:\Data Dictionary.docx"
Dim wApp As Word.Application: Set wApp = Set wApp = New Word.Application
Dim wDoc As Word.Document: Set wDoc = wApp.Documents.Open(FilePath, , True)
Dim Data As Variant: ReDim Data(1 To wDoc.Paragraphs.Count, 1 To 1)
Dim wPara As Word.Paragraph
Dim r As Long
For Each wPara In wDoc.Paragraphs
If wPara.Range.Words.Count > 1 Then
r = r + 1
Data(r, 1) = wPara.Range
End If
Next wPara
wDoc.Close False
wApp.Quit
[a1].Resize(r) = Data
End Sub
Sub ParaCopyNoReference()
Const FilePath As String = "J:\Data Dictionary.docx"
With CreateObject("Word.Application")
With .Documents.Open(FilePath, , True)
Dim Data As Variant: ReDim Data(1 To .Paragraphs.Count, 1 To 1)
Dim wPara As Object
Dim r As Long
For Each wPara In .Paragraphs
If wPara.Range.Words.Count > 1 Then
r = r + 1
Data(r, 1) = wPara.Range
End If
Next wPara
.Close False
End With
.Quit
End With
[a1].Resize(r) = Data
End Sub

Array of unique values in a Column range

Trying to figure out the code to make an array of all unique values in a column.
So like say from C3:C30 I want an array named divisionNames of all unique values in that range. I intend to use the array later in the code. Trying to figure out a minimalist way of doing it so I don't add like 60 more lines of code to the macro.
Would be very appreciative of any suggestions
UPDATE:
Gary's Student's response below did the trick for what I needed, but I very much appreciate the help everyone gave. Thank you. Also as a side note I am now realizing I should have added that I am using Office 365. To be honest I didn't realize it made that much of a difference, but I will remember that for future reference and again thank you for all of the help
Sub uniq()
With Application.WorksheetFunction
divisionNames = .Unique(Range("C3:C30"))
End With
End Sub
With Excel 365:
Sub uniq()
With Application.WorksheetFunction
divisionNames = .Unique(Range("C3:C30"))
End With
End Sub
EDIT#1:
This version will sort the results and put the data in column D:
Sub uniq()
With Application.WorksheetFunction
divisionNames = .Unique(Range("C3:C30"))
divisionNames = .Sort(divisionNames)
End With
u = UBound(divisionNames, 1)
Range("D3:D" & 3 + u - 1).Value = divisionNames
End Sub
Unique (Dictionary)
There is no error handling i.e. it is assumed that the range is a one-column range and that there are no error or empty values. This could be easily implemented, but you wanted it short.
1D - Function
Function getUniqueColumn1D(ColumnRange As Range)
Dim Data As Variant
Data = ColumnRange.Resize(, 1).Value
With CreateObject("Scripting.Dictionary")
Dim i As Long
For i = 1 To UBound(Data)
.Item(Data(i, 1)) = Empty
Next
ReDim Data(1 To .Count)
i = 0
Dim key As Variant
For Each key In .Keys
i = i + 1
Data(i) = key
Next key
End With
getUniqueColumn1D = Data
End Function
Sub test1D()
Dim rng As Range
Set rng = Range("C3:C30")
Dim Data As Variant
Data = getUniqueColumn1D(rng)
Debug.Print Join(Data, vbLf)
End Sub
2D - Function
Function getUniqueColumn(ColumnRange As Range)
Dim Data As Variant
Data = ColumnRange.Resize(, 1).Value
With CreateObject("Scripting.Dictionary")
Dim i As Long
For i = 1 To UBound(Data)
.Item(Data(i, 1)) = Empty
Next
ReDim Data(1 To .Count, 1 To 1)
i = 0
Dim key As Variant
For Each key In .Keys
i = i + 1
Data(i, 1) = key
Next key
End With
getUniqueColumn = Data
End Function
Sub TESTgetUniqueColumn()
Dim rng As Range
Set rng = Range("C3:C30")
Dim Data As Variant
Data = getUniqueColumn(rng)
' e.g.
Dim i As Long
For i = 1 To UBound(Data)
Debug.Print Data(i, 1)
Next i
' or:
Range("A1").Resize(UBound(Data, 1), UBound(Data, 2)).Value = Data
End Sub
2D - Sub
Sub getUniqueColumnSub()
Dim Data As Variant
Data = Range("C3:C30")
With CreateObject("Scripting.Dictionary")
Dim i As Long
For i = 1 To UBound(Data)
.Item(Data(i, 1)) = Empty
Next
ReDim Data(1 To .Count, 1 To 1)
i = 0
Dim key As Variant
For Each key In .Keys
i = i + 1
Data(i, 1) = key
Next key
End With
' e.g.
For i = 1 To UBound(Data)
Debug.Print Data(i, 1)
Next i
' or:
Range("A1").Resize(UBound(Data, 1), UBound(Data, 2)).Value = Data
End Sub

Copy Multiple Non-Adjacent Columns To Array

I'm trying to copy multiple non-adjacent (non-contiguous) excel columns to an array but it's not working. Below is what I've tried...
Public Function Test()
Dim sh As Worksheet: Set sh = Application.Sheets("MyWorksheet")
Dim lr As Long: lr = sh.Cells(sh.Rows.Count, 1).End(xlUp).row
Dim r1 As Range: Set r1 = sh.Range("A1:A" & lr)
Dim r2 As Range: Set r2 = sh.Range("C1:C" & lr)
Dim rAll As Range: Set rAll = Union(r1, r2)
'Dim arr() As Variant: arr = Application.Transpose(rAll) <-- Throws Type mismatch error
'Dim arr As Variant: arr = Application.Transpose(rAll) <-- arr Value = Error 2015
Dim arr() As Variant: arr = rAll.Value2 ' <-- Only the first column (col A) is loaded.
End Function
Any help is greatly appreciated!
Since reading multiple values into an array like arr = rAll.Value2 is only possible in continous ranges, you have to alternatives:
Alternative 1:
Write a function that reads the range values area wise and merge it into one array.
Option Explicit
Public Function NonContinousColumnsToArray(ByVal NonContinousRange As Range) As Variant
Dim iArea As Long
For iArea = 1 To NonContinousRange.Areas.Count - 1
If NonContinousRange.Areas.Item(iArea).Rows.CountLarge <> NonContinousRange.Areas.Item(iArea + 1).Rows.CountLarge Then
MsgBox "Different amount of rows is not allowed.", vbCritical, "NonContinousColumnsToArray"
Exit Function
End If
Next iArea
Dim ArrOutput() As Variant
ArrOutput = NonContinousRange.Value2 'read first area into array
'read all other areas
For iArea = 2 To NonContinousRange.Areas.Count
ReDim Preserve ArrOutput(1 To UBound(ArrOutput, 1), 1 To UBound(ArrOutput, 2) + NonContinousRange.Areas.Item(iArea).Columns.CountLarge) As Variant 'resize array
Dim ArrTemp() As Variant 'read arrea at once into temp array
ArrTemp = NonContinousRange.Areas.Item(iArea).Value2
'merge temp array into output array
Dim iCol As Long
For iCol = 1 To UBound(ArrTemp, 2)
Dim iRow As Long
For iRow = 1 To UBound(ArrTemp, 1)
ArrOutput(iRow, UBound(ArrOutput, 2) - UBound(ArrTemp, 2) + iCol) = ArrTemp(iRow, iCol)
Next iRow
Next iCol
Next iArea
NonContinousColumnsToArray = ArrOutput
End Function
So the following example procedure
Public Sub ExampleTest()
Dim InputRng As Range
Set InputRng = Union(Range("A1:A9"), Range("C1:D9"))
Dim OutputArr() As Variant
OutputArr = NonContinousColumnsToArray(InputRng)
Range("A12").Resize(UBound(OutputArr, 1), UBound(OutputArr, 2)).Value = OutputArr
End Sub
would take the following non-continous range Union(Range("A1:A9"), Range("C1:D9")) as input,
Image 1: The input range was non-continous A1:A9 and C1:D9.
merge it into one array OutputArr and write the values as follows
Image 2: The merged output array written back into cells.
Alterantive 2: Using a temporary worksheet …
… to paste the values as continous range, which then can be read into an array at once.
Public Sub ExampleTestTempSheet()
Dim InputRng As Range
Set InputRng = Union(Range("A1:A9"), Range("C1:D9"))
Dim OutputArr() As Variant
OutputArr = NonContinousColumnsToArrayViaTempSheet(InputRng)
Range("A12").Resize(UBound(OutputArr, 1), UBound(OutputArr, 2)).Value = OutputArr
End Sub
Public Function NonContinousColumnsToArrayViaTempSheet(ByVal NonContinousRange As Range) As Variant
On Error Resume Next
NonContinousRange.Copy
If Err.Number <> 0 Then
MsgBox "Different amount of rows is not allowed.", vbCritical, "NonContinousColumnsToArray"
Exit Function
End If
On Error GoTo 0
Dim TempSheet As Worksheet
Set TempSheet = ThisWorkbook.Worksheets.Add
TempSheet.Range("A1").PasteSpecial xlPasteValues
Application.CutCopyMode = False
NonContinousColumnsToArrayViaTempSheet = TempSheet.UsedRange.Value2
Dim ResetDisplayAlerts As Boolean
ResetDisplayAlerts = Application.DisplayAlerts
Application.DisplayAlerts = False
TempSheet.Delete
Application.DisplayAlerts = ResetDisplayAlerts
End Function
Note that the alternative 2 is more likely to fail, because of the temporary worksheet. I think alternative 1 is more robust.
Alternative solution via Application.Index() function
Just for fun an alternative solution allowing even a resorted column order A,D,C:
Sub ExampleCall()
'[0]define range
With Sheet1 ' reference the project's source sheet Code(Name), e.g. Sheet1
Dim lr As Long: lr = .Cells(.Rows.Count, 1).End(xlUp).Row
Dim rng As Range: Set rng = .Range("A1:D" & lr)
End With
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'[1]get data in defined columns order A,C,D
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Dim data: data = RearrangeCols(rng, "A,D,C")
'[2]write to any target range
Sheet2.Range("F1").Resize(UBound(data), UBound(data, 2)) = data
End Sub
Help functions called by above main procedure
Function RearrangeCols(rng As Range, ByVal ColumnList As String)
'Purpose: return rearranged column values based on ColumnList, e.g. Columns A,C,D instead of A:D
'[a]assign data to variant array
Dim v: v = rng
'[b]rearrange columns
v = Application.Index(v, Evaluate("row(1:" & UBound(v) & ")"), GetColNums(ColumnList)) ' Array(1, 3, 4)
'[c]return rearranged array values as function result
RearrangeCols = v
End Function
Function GetColNums(ByVal ColumnList As String, Optional ByVal Delim As String = ",") As Variant()
'Purpose: return array of column numbers based on argument ColumnList, e.g. "A,C,D" ~> Array(1, 3, 4)
'[a]create 1-dim array based on string argument ColumnList via splitting
Dim cols: cols = Split(ColumnList, Delim)
'[b]get the column numbers
ReDim tmp(0 To UBound(cols))
Dim i: For i = 0 To UBound(tmp): tmp(i) = Range(cols(i) & ":" & cols(i)).Column: Next
'[c]return function result
GetColNums = tmp
End Function
Further solution //Edit as of 2020-06-11
For the sake of completeness I demonstrate a further solution based on an array of arrays (here: data) using the rather unknown double zero argument in the Application.Index() function (see section [2]b):
data = Application.Transpose(Application.Index(data, 0, 0))
Sub FurtherSolution()
'[0]define range
With Sheet1 ' reference the project's source sheet Code(Name), e.g. Sheet1
Dim lr As Long: lr = .Cells(.Rows.Count, 1).End(xlUp).Row
Dim rng As Range: Set rng = .Range("A1:D" & lr)
End With
'[1]assign data to variant array
Dim v: v = rng
'[2]rearrange columns
'a) define "flat" 1-dim array with 1-dim column data A,C,D (omitting B!)
Dim data
data = Array(aCol(v, 1), aCol(v, 3), aCol(v, 4))
'=====================
'b) create 2-dim array
'---------------------
data = Application.Transpose(Application.Index(data, 0, 0))
'[3]write to any target range
Sheet2.Range("F1").Resize(UBound(data), UBound(data, 2)) = data
End Sub
Function aCol(DataArr, ByVal colNo As Long) As Variant()
'Purpose: return entire column data as "flat" 1-dim array
With Application
aCol = .Transpose(.Index(DataArr, 0, colNo))
End With
End Function
Caveat: This 2nd approach seems to be less performant for greater data sets.
Related link
Some pecularities of the Application.Index() function
Thank you PEH,
Great explanation which led me to the following solution:
Function Test()
Dim sh as Worksheet : set sh = Sheets("MySheet")
Dim lr as Long : lr = sh.Cells(sh.Rows.Count, 1).End(xlUp).row
Dim arr () as Variant
Dim idx as Long
' Delete unwanted columns to ensure contiguous columns...
sh.Columns("B:B").Delete
' Load Array
arr = Sheet("MySheet").Range("A1:B" & lr).value2
' This allows speedy index finds... Note, index(arr, startrow, keycol)
' Will need to use "On Error" to handle key not being found
idx = WorksheetFunction.match("MyKey", WorksheetFunction.Index(arr, 0, 2), 0)
' And then fast processing through the array
For idx = idx to lr
if (arr(idx, 2) <> "MyKey") then exit for
' do some processing...
Next idx
End Function
Thank you again!
The idea behind using arrays is to increase speed. Moving and deleting columns, as well as "for" looping slows you down.
I'm looking for a way to speed up one of my procedures from 120,000 µs to 60,000 or less.
The proposed solutions slow it down to 450,000.

Stacking several ranges into a dynamic array

Hopefully i've phrased that right...
I came across something online stating that copy and pasting wastes precious time. It's better to assign values more directly, without using excel functions.
I found a section in a VBA book explaining how to store a range in a 2D array.
Now what if I wanted to copy and paste a range from a dynamic number of worksheets into another one main sheet with this method?
In my head, I imagine stacking more and more values into an array, then dumping the array where I'd like it to go, into a range whose size is defined by the dimensions of the big array.
In practice, all I have managed to create is something like the below, performing the same simple action for each worksheet in turn.
Is it possible to do this better? That runs faster? Help a brother out!
Sub arrayCopyPaste()
Dim Obj As Range
Dim Data As Variant
Dim ws As Worksheet
Dim sheetCount As Integer
Dim LR As Integer
sheetCount = Sheets.Count
Set ws = Sheets.Add
ws.Move After:=Worksheets(Worksheets.Count)
For i = 1 To sheetCount
Data = Sheets(i).Range("A1:B9")
LR = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
Set Obj = ws.Range("A" & LR)
Set Obj = Obj.Resize(UBound(Data, 1), UBound(Data, 2))
Obj.Value = Data
Next i
End Sub
With just about any code I use, I like to make a call to this routine I made:
Sub SpeedupCode(Optional ByVal Val As Boolean = True)
With Application
If Val = True Then
.ScreenUpdating = False
.Calculation = xlCalculationManual
Else
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
End If
End With
End Sub
So, in your code you would simply use it as follows:
Sub arrayCopyPaste()
Dim Obj As Range
Dim Data As Variant
Dim ws As Worksheet
Dim sheetCount As Integer
Dim LR As Integer
SpeedupCode
sheetCount = Sheets.Count
Set ws = Sheets.Add
ws.Move After:=Worksheets(Worksheets.Count)
For i = 1 To sheetCount
Data = Sheets(i).Range("A1:B9")
LR = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
Set Obj = ws.Range("A" & LR)
Set Obj = Obj.Resize(UBound(Data, 1), UBound(Data, 2))
Obj.Value = Data
Next i
SpeedupCode False
End Sub
While this does not necessarily optimize your code, it can significantly improve the performance on every project that you do. In the event that your code requires a newly calculated variable in your worksheet, you can always use Application.Calculate before you grab that variable, but generally, it shouldn't be needed.
I'd be inclined to use your current approach and just boil it down a bit.
Sub arrayCopyPaste()
Dim ws As Worksheet
Set ws = Sheets.Add(After:=Worksheets(Worksheets.Count))
For i = 1 To Sheets.Count - 1
With Sheets(i).Range("A1:B9")
ws.Cells(ws.Rows.Count, 1).End(xlUp).Offset(1, 0).Resize( _
.Rows.Count, .Columns.Count).Value = .Value
End With
Next i
End Sub
This version is slightly more efficient due to writing the results all at once, though you probably won't notice much of a difference unless you're working with very large ranges.
Sub test()
'Same as original: final array is 2 columns wide, (3 * number of sheets) rows long
Call mergeRangeValues("A1:B3", "Results", True)
'Alternate version: final array is 3 rows long, (2 * number of sheets) columns wide
'Call mergeRangeValues("A1:B3", "Results", False)
End Sub
Sub mergeRangeValues(rngString As String, newWSName As String, stackRows As Boolean)
'Merges the same range (rngString) from all sheets in a workbook
'Adds them to a new worksheet (newWSName)
'If stackRows = True, values are stacked vertically
'If stackRows = False, values are stacked horizontally
Dim sheetCount As Long
Dim newWS As Worksheet
sheetCount = ThisWorkbook.Sheets.Count
Set newWS = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(sheetCount))
newWS.Name = newWSName
Dim numCols As Long
Dim numRows As Long
numCols = newWS.Range(rngString).Columns.Count * IIf(stackRows, 1, sheetCount)
numRows = newWS.Range(rngString).Rows.Count * IIf(stackRows, sheetCount, 1)
ReDim resultsArr(1 To numRows, 1 To numCols) As Variant
'''Longer version:
'If stackRows Then
'numCols = newWS.Range(rngString).Columns.Count
'numRows = newWS.Range(rngString).Rows.Count * sheetCount
'Else
'numCols = newWS.Range(rngString).Columns.Count * sheetCount
'numRows = newWS.Range(rngString).Rows.Count
'End If
'''ie "If you want to stack the results vertically, make the array really long"
'''or "If you want to stack the results horizontally, make the array really wide"
Dim i As Long
For i = 0 To sheetCount - 1
Dim tempArr As Variant
tempArr = ThisWorkbook.Sheets(i + 1).Range(rngString).Value
Dim j As Long
Dim k As Long
If stackRows Then
For j = LBound(tempArr, 1) To UBound(tempArr, 1)
For k = LBound(tempArr, 2) To UBound(tempArr, 2)
resultsArr(j + i * (numRows / sheetCount), k) = tempArr(j, k)
Next
Next
Else
For j = LBound(tempArr, 1) To UBound(tempArr, 1)
For k = LBound(tempArr, 2) To UBound(tempArr, 2)
resultsArr(j, k + i * (numCols / sheetCount)) = tempArr(j, k)
Next
Next
End If
Next
With newWS
.Range(.Cells(1, 1), .Cells(numRows, numCols)).Value = resultsArr
End With
End Sub

Error in converting Range to arrays

Anybody please help me figure my problem out?
Dim attPresent as Variant ' attpresent()
Set ws = thisworkbook.sheets("Sheet1")
lastrow = ws.cells(Rows.count, 8).end(xlup).row
attPresent = ws.Range("H4:H" & lastrow).Value 'errors if I use Dim attPresent() As Variant
For k = LBound(attPresent, 1) To UBound(attPresent, 1) ' Dim attPresent As Variant'errors if I use
msgbox attpresent(k,1)
Next
This line attPresent = ws.Range("H4:H" & lastrow).Value returns an error if I declare the variable as Dim attPresent() As Variant. Whereas, if declare the variable as Dim attPresent As Variant, this line For k = LBound(attPresent, 1) To UBound(attPresent, 1) errors.
Can anyone please help me clear this out?Thanks
As a good practice, try to remember to use Option Explicit, and also declare all your variables.
When you use Dim attPresent() As Variant to declare you array , and later on you insert values from a Range to your Array with attPresent = .Range("H4:H" & lastrow).Value, it will automatically Redim your array to 2-dimensinal array (1 to Row number, 1 to Column Number).
Option Explicit
Sub RngtoArray()
Dim attPresent() As Variant
Dim ws As Worksheet
Dim lastrow As Long
Dim k As Long
Set ws = ThisWorkbook.Sheets("Sheet1")
With ws
lastrow = .Cells(.Rows.Count, 8).End(xlUp).Row
attPresent = .Range("H4:H" & lastrow).Value
End With
For k = 1 To UBound(attPresent, 1)
MsgBox attPresent(k, 1)
Next
End Sub
Edit 1: A slightly different approach, in case there is only 1 cell in the Range:
With ws
lastrow = .Cells(.Rows.Count, 8).End(xlUp).Row
' for single column only - create a 1-Dimension array
ReDim attPresent(1 To lastrow - 4 + 1) ' when the Range starts from "H4"
For k = 1 To UBound(attPresent)
attPresent(k) = .Cells(4 + k - 1, "H")
Next k
End With
For k = 1 To UBound(attPresent)
MsgBox attPresent(k)
Next
I tried to separate the stuff that you had already defined but for clarity I thought I'd provide my full code:
Sub test()
Dim lastrow, i As Integer
Dim ws As Worksheet
Set ws = ActiveWorkbook.Worksheets("Sheet1")
Dim attPresent() As Variant
lastrow = ws.Cells(Rows.Count, "H").End(xlUp).Row
ReDim attPresent(lastrow - 4)
For i = 4 To lastrow
attPresent(i - 4) = ws.Range("H" & i).Value
Next
msg = Join(attPresent, " ")
MsgBox "The array holds: " & vbNewLine & msg
End Sub
I defined the array without a size to begin with then redefined it to the size it needs to be at a later stage once you know the lastrow (as you started on 4 i deducted 4 from lastrow).
I guessed the msgBox was to test what you had gathered so I created a dump that prints them all into one box but obviously change that if you have a lot of data. xD
To work with arrays I always loop through each individual entry, storing them one at a time. I'm not even sure whether you can dump an entire range into one in one step as I've never even looked into it. Anyway, I hope this solves your problem kupo.
Function RangeToArray(rng As Range)
Dim myArray() As Variant, ws As Worksheet
fr = rng.Row
fc = rng.Column
r = rng.Rows.Count
c = rng.Columns.Count
Set ws = rng.Worksheet
ReDim myArray(r - 1, c - 1)
For i = 0 To r - 1
For j = 0 To c - 1
myArray(i, j) = ws.Cells(fr + i, fc + j).Value2
Next j
Next i
RangeToArray = myArray
End Function
Sub f()
Dim rng As Range, attPresent() As Variant ' attpresent()
Set ws = ThisWorkbook.ActiveSheet 'Sheets("Sheet1")
lastrow = ws.Cells(Rows.Count, 8).End(xlUp).Row
Set rng = ws.Range("H4:H" & lastrow)
attPresent = RangeToArray(rng)
For k = LBound(attPresent, 1) To UBound(attPresent, 1) ' Dim attPresent As Variant'errors if I use
MsgBox attPresent(k, 0)
Next
End Sub
I created a more generic function that you can call in this specific case as well.

Resources