I create an array in vba by looping through cells in a sheet (originalWS). So let's say cells (2,5) to (2,12) have the following:
(2,5)Item
(3,5)Type
(4,5)Nominal Diameter
(5,5)Lead
.
.
.
(12,5)For Use with End Blocks
Thus, when I loop with the code below I get an array that looks like this:
[Item,Type,Nominal Diameter,Lead,...,For Use with End Blocks].
However, I would like to add two empty spaces between each value in my array. so that it looks like this:
[Item,"","",Type,"","",Nominal Diameter,"","",Lead,"","",...,For Use with End Blocks,"",""]
ReDim propertyArr(1, lastRow)
For i = 1 To lastRow
propertyArr(1, i) = originalWS.Cells(i + 1, 5).Value
Debug.Print propertyArr(1, i)
Next
I have tried to loop to by the final total size of the array so (lastRow*3) and step forward by 3. However, I'm having a hard time figuring out how I would reset my orginalWS.cells(i,5) values so that they are consecutive.
In other words, when I loop stepping by 3 my values would be:
propertyArr(1,1) = originalWS.Cells(2,5).value
propertyArr(1,4) = originalWS.cells(5,5).value
propertyArr(1,7) = originalWS.cells(8,5).value
How can I loop so that I store values in my array every 2 places, while I get the values from a consecutive list in a sheet.
Can I do this without having to add extra empty row
a way to add two empty spaces between each value within my original loop without having to add extra empty rows?
Or, can I add the two empty spaces between each value after I created my array the first time?
This should do the trick,
Dim lRowNo As Long
lRowNo = lastRow * 3
ReDim propertyArr(1, lRowNo)
For i = 1 To lRowNo
If i Mod 3 = 1 Then
propertyArr(1, i) = originalWS.Cells(i + 1, 5).Value
Else
propertyArr(1, i) = ""
End If
Debug.Print propertyArr(1, i)
Next
Something like:
Sub ytrewq()
Dim propertyArr(), lastRow As Long
Dim originalWS As Worksheet
Set originalWS = ActiveSheet
lastRow = 5
ReDim propertyArr(1, 2 * lastRow)
For i = 1 To 2 * lastRow Step 2
propertyArr(1, i) = originalWS.Cells(i + 1, 5).Value
propertyArr(1, i + 1) = ""
Debug.Print propertyArr(1, i)
Next
End Sub
UNTESTED
You can also unroll the loop a bit to do this a bit more efficiently. Note that for each iteration, i isn't incremented by 1, but by 3.
Public Sub test()
Dim lastRow As Long
lastRow = 6
Dim lastIndex As Long
lastIndex = lastRow * 3
ReDim propertyArr(1 To lastIndex)
Dim i As Long
For i = 1 To lastIndex Step 3
propertyArr(i) = CInt(i / 3)
propertyArr(i + 1) = vbNullString
propertyArr(i + 2) = vbNullString
Next
End Sub
Or without loops
Dim ws As Worksheet
Set ws = Sheets(1)
propertyarr = Join(Application.Transpose(ws.Range("E1:E5")), ","""","""",")
to put back into array
propertyarr = Split(Join(Application.Transpose(ws.Range("E1:E5")), ",,,"), ",")
I figured out the answer. I wasn't updating the cells I needed correctly. See code below:
count = 3
lastIndex = lastRow * 3
ReDim propertyArr(1, lastIndex)
For i = 1 To lastIndex Step 3
propertyArr(1, i) = originalWS.Cells((count - 1), 5)
count = count + 1
Next
Related
This should be easy and I think I am almost there. I would like to count how many times an entry repeats itself within a certain array. The array will be populated from a range. Eventually if the number of the count is more than 4, I would like to insert "Excess", otherwise if less than 4, I would like to insert "Insufficient", else is "complete". Unfortunately, even though I have learnt to do these calculations without using Arrays, I find some difficulties when switching to Arrays.
How the code should look like
Sub test()
Dim MyArray() As Variant, Countarrays() As Variant, Result() As Variant
Dim r As Range
Dim rows As Integer
Worksheets("Sheet1").Activate
Set r = Range("B2", Range("B1").End(xlDown))
MyArray = Range("B2", Range("B1").End(xlDown))
rows = Range("B2", Range("B1").End(xlDown)).Count
For i = 0 To rows
For j = 0 To rows
Countarrays(i, 1) = WorksheetFunction.CountIf(r, MyArray(i))
If (Countarrays(i, 1).value) > 4 Then Result(j, 1) = "Excess"
ElseIf (Countarrays(i, 1).value) < 4 Then Result(j, 1) = "Insufficient"
ElseIf (Countarrays(i, 1).value) = 4 Then Result(j, 1) = "Complete"
Next j
Next i
End Sub
This should do the trick:
Option Explicit
Sub Test()
Dim MyArray, DictDuplicates As New Scripting.Dictionary, i As Long
With ThisWorkbook.Sheets("Sheet1") 'change if needed
MyArray = .Range(.Cells(2, 1), .Cells(2, 2).End(xlDown))
For i = LBound(MyArray) To UBound(MyArray) 'loop to store all the items and how many times do they repeat
If Not DictDuplicates.Exists(MyArray(i, 2)) Then 'if doesn't exists will store it
DictDuplicates.Add MyArray(i, 2), 1
Else 'if it does exists will increment its item value
DictDuplicates(MyArray(i, 2)) = DictDuplicates(MyArray(i, 2)) + 1
End If
Next i
For i = LBound(MyArray) To UBound(MyArray) 'loop to give back the result
Select Case DictDuplicates(MyArray(i, 2))
Case Is > 4
MyArray(i, 1) = "Excess"
Case Is = 4
MyArray(i, 1) = "Complete"
Case Is < 4
MyArray(i, 1) = "Insufficient"
End Select
Next i
.Range(.Cells(2, 1), .Cells(2, 2).End(xlDown)) = MyArray
End With
End Sub
Note that for the DictDuplicates to work, you need to check the Microsoft Scripting Runtime library.
I have a very basic question, but would love to know how to do this. I want to write a function in VBA where I can highlight a column as an input, and then spit out the result somewhere else.
Thanks in advance :)
e.g. column A
--------
10
8
5
6
1
3
2
becomes:
column A
--------
10
8
6
2
I just did it from column a to b, but you probably want range as the current selection and a different output column.
Option Explicit
Sub filterlist()
Dim rng As Range
Set rng = Range("a1:a5")
Dim celluse As Range
Dim arr As Variant
For Each celluse In rng
If celluse.Value Mod 2 = 0 Then
If IsEmpty(arr) Then
arr = Array(celluse.Value)
Else
ReDim Preserve arr(UBound(arr) + 1)
arr(UBound(arr)) = celluse.Value
End If
End If
Next celluse
Dim i As Long
For i = 0 To UBound(arr)
Range("b" & i + 1) = arr(i)
Next i
End Sub
This code should do the trick.
You can enter as an array-formula directly to a sheet: {=RemoveOdds(A1:A7)} or as part of another procedure:
Sub Test()
RemoveOdds Selection
End Sub
Public Function RemoveOdds(Target As Range) As Variant
Dim vFinal() As Variant
Dim rCell As Range
Dim x As Long
ReDim vFinal(1 To Target.Cells.Count)
x = 1
For Each rCell In Target
If rCell Mod 2 = 0 Then
vFinal(x) = rCell.Value
x = x + 1
End If
Next rCell
'So missing values do not show up as 0 at bottom of array.
' Do While x <= Target.Cells.Count
' vFinal(x) = ""
' x = x + 1
' Loop
ReDim Preserve vFinal(1 To x - 1)
'RemoveOdds = vFinal 'Basic array - will place values horizontally on sheet.
RemoveOdds = Application.Transpose(vFinal) 'Will place values vertically on sheet.
End Function
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
I have a giant dataset that looks like this
I am trying to go down the list of different companies and grab 3 per company and combine them. Based on the photo above, I would have 2 different lists with 3 companies each (except TH Repair which will have 2 in the final list).
My real dataset contains hundreds of different companies, each with dozens/hundreds of entries so I would finish with dozens of lists (each potentially hundreds long).
I tried to record a macro and ended up with this code
Sub Loop1()
'
' Loop1 Macro
'
'
Range("A4:E6").Select
Selection.Copy
Sheets("Sheet3").Select
Range("A18").Select
ActiveSheet.Paste
Sheets("Sheet2").Select
Range("A11:E13").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Sheet3").Select
Range("A21").Select
ActiveSheet.Paste
Sheets("Sheet2").Select
Range("A17:E19").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Sheet3").Select
Range("A24").Select
ActiveSheet.Paste
End Sub
However, this turned out to be WAY more complicated then I expected.
I am looking for the end result to look like this
See if something like this works for you. I only ran one scenario through it so you will want to test it more.
This makes the assumption that the data is sorted by column B on the original sheet
This procedure makes an assumption that there is either headers or no data on row 1.
You will need to change the "Sheet1" in this line Set ws1 = ActiveWorkbook.Worksheets("Sheet1") to the name of the sheet you are starting with.
Option Explicit
Public Sub MoveData()
Dim ws1 As Worksheet
Set ws1 = ActiveWorkbook.Worksheets("Sheet1")
Dim ws2 As Worksheet
Set ws2 = ActiveWorkbook.Worksheets.Add()
Dim rw As Long
Dim match_count As Integer
Dim list_multiplier As Integer
list_multiplier = 7
Dim list_row() As Long
ReDim list_row(0)
list_row(0) = 2
For rw = 2 To ws1.Range("A" & ws1.Rows.Count).End(xlUp).Row
If ws1.Range("B" & rw).Value <> ws1.Range("B" & rw).Offset(-1, 0).Value Then
match_count = 0
Else
match_count = match_count + 1
End If
Dim list_num As Integer
list_num = match_count \ 3
If list_num > UBound(list_row, 1) Then
ReDim Preserve list_row(list_num)
list_row(list_num) = 2
End If
ws2.Cells(list_row(list_num), 1 + list_multiplier * list_num).Value = ws1.Range("A" & rw).Value
ws2.Cells(list_row(list_num), 2 + list_multiplier * list_num).Value = ws1.Range("B" & rw).Value
ws2.Cells(list_row(list_num), 3 + list_multiplier * list_num).Value = ws1.Range("C" & rw).Value
ws2.Cells(list_row(list_num), 4 + list_multiplier * list_num).Value = ws1.Range("D" & rw).Value
ws2.Cells(list_row(list_num), 5 + list_multiplier * list_num).Value = ws1.Range("E" & rw).Value
list_row(list_num) = list_row(list_num) + 1
Next rw
End Sub
When you record your macro, ensure that "Use Relative References" on the Developer Ribbon tab is enabled, :)
assuming row 3 has your data headers, you could try this:
Option Explicit
Sub main()
Dim nLists As Long, iList As Long
Dim data As Variant
Dim dataToDelete As Range
With Range("F3", Cells(Rows.Count, 1).End(xlUp))
data = .Value
nLists = WorksheetFunction.Max(.Resize(,1))
nLists = nLists \ 3 + IIf(nLists - 3 * (nLists \ 3) = 0, -1, 0)
End With
With Range("A3").Resize(, 6)
For iList = 0 To nLists
Set dataToDelete = Nothing
With .Offset(, iList * 6).Resize(UBound(data))
.Value = data
.AutoFilter Field:=1, Criteria1:="<=" & iList * 3, Criteria2:=">" & (iList + 1) * 3, Operator:=xlOr
If Application.WorksheetFunction.Subtotal(103, .Cells) > 1 Then Set dataToDelete = .Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible)
.Parent.AutoFilterMode = False
If Not dataToDelete Is Nothing Then dataToDelete.Delete xlShiftUp
End With
Next
End With
End Sub
Your task is actually slightly trickier than your online advice suggests. Basically, you have to do the following:
Find out how many unique 'keys' (ie unique items in column B) you have. This will tell you the total number of rows you need (ie number of unique keys * 3)
Count the number of items for each 'key'. This will tell you how many columns you need (ie max item count / 3 * number of columns in array [A:E = 5])
Loop through each line of data and it put on appropriate row for that 'key'. Once three has been reached, jump the column for that key 6 columns to the right, and continue.
If you were to use a Class object and Collection type of object, this could be really quite concise code, but judging by your post you are at the beginning of your programming journey in VBA. Therefore, I've broken down each task into separate chunks of code so you will hopefully see how arrays can work for you. Once you practise with arrays a little, perhaps you could have a go at making this code more efficient by combining some of the loops:
Public Sub RunMe()
Dim data As Variant
Dim r As Long, c As Long, i As Long, dataRows As Long, dataCols As Long, keyLen As Long, maxCount As Long
Dim keys As String
Dim k As Variant
Dim keyArray() As String
Dim keyCount() As Long, threeCount() As Long, rowNum() As Long, colNum() As Long
Dim output() As Variant
'Read the data - change "Sheet1" to your sheet name.
'Shows how to write range values into a variant to
'create an array of variants.
data = ThisWorkbook.Worksheets("Sheet1").UsedRange.Value2
dataRows = UBound(data, 1)
dataCols = UBound(data, 2)
'Create a list of unique keys.
'Note: not the most efficient way, but shows how to
'create an array from a value-separated string.
For r = 1 To dataRows
If InStr(keys, CStr(data(r, 2))) = 0 Then
If Len(keys) > 0 Then keys = keys & "|"
keys = keys & CStr(data(r, 2))
End If
Next
keyArray = Split(keys, "|")
keyLen = UBound(keyArray)
'Initialise the row and column numbers for each key.
'Shows how to iterate an array using For Each loop.
ReDim rowNum(keyLen)
ReDim colNum(keyLen)
r = 1
i = 0
For Each k In keyArray
rowNum(i) = r
colNum(i) = 1
r = r + 3
i = i + 1
Next
'Count the number of items for each key.
'Shows how to iterate an array using For [index] loop.
ReDim keyCount(keyLen)
For r = 1 To dataRows
i = IndexOfKey(keyArray, CStr(data(r, 2)))
keyCount(i) = keyCount(i) + 1
If keyCount(i) > maxCount Then maxCount = keyCount(i)
Next
'Size the output array.
c = WorksheetFunction.Ceiling(maxCount / 3, 1)
ReDim output(1 To (keyLen + 1) * 3, 1 To c * dataCols + c - 1)
'Populate the output array.
ReDim threeCount(keyLen)
For r = 1 To dataRows
i = IndexOfKey(keyArray, CStr(data(r, 2)))
'Copy the columns for this row.
For c = 1 To dataCols
output(rowNum(i), colNum(i) + c - 1) = data(r, c)
Next
'Increment the count and if it's equals 3 then
'reset the row num and increase the column number.
threeCount(i) = threeCount(i) + 1
rowNum(i) = rowNum(i) + 1
If threeCount(i) = 3 Then
rowNum(i) = rowNum(i) - 3
colNum(i) = colNum(i) + dataCols + 1
threeCount(i) = 0
End If
Next
'Write the data - change "Sheet2" to your sheet name.
'Shows how to write an array to a Range.
ThisWorkbook.Worksheets("Sheet2").Range("A3") _
.Resize(UBound(output, 1), UBound(output, 2)).Value = output
End Sub
Private Function IndexOfKey(list() As String, key As String) As Long
Dim i As Long
Dim k As Variant
'Helper function to find index position of key in array.
For Each k In list
If key = k Then
IndexOfKey = i
Exit Function
End If
i = i + 1
Next
IndexOfKey = -1
End Function
I need to do the following:
lift the range C2:AU264 into an 2D array
create another 1D array, (1 To 11880)
fill second array with values from the first one ("transpose")
write array 2 back to the sheet
Here is the code I am using:
Private Ws As Worksheet
Private budgets() As Variant
Private arrayToWrite() As Variant
Private lastrow As Long
Private lastcol As Long
Private Sub procedure()
Application.ScreenUpdating = False
Set Ws = Sheet19
Ws.Activate
lastrow = Ws.Cells.Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).row
lastcol = Ws.Cells.Find("*", searchorder:=xlByColumns, searchdirection:=xlPrevious).Column
ReDim budgets(1 To lastrow - 1, 1 To lastcol - 2)
budgets= Ws.Range("C2:AU265")
ReDim arrayToWrite(1 To (lastCol - 2) * (lastRow - 1))
k = 0
For j = 1 To UBound(budgets, 2)
For i = 1 To UBound(budgets, 1)
arrayToWrite(i + k) = budgets(i, j)
Next i
k = k + lastrow - 1
Next j
Set Ws = Sheet6
Ws.Activate
Ws.Range("E2").Resize(UBound(arrayToWrite)).Value = arrayToWrite
'For i = 1 To UBound(arrayToWrite)
'Ws.Range(Cells(i + 1, 5).Address).Value = arrayToWrite(i)
'Next i
Application.ScreenUpdating = True
End Sub
This just writes the first value from the range C2:AU264 (the first element of the first array) through the whole range E2:E11881. If however, I un-comment the For loop just before the end of my script and do it that way, it does work, but is slow. How can I write the array correctly using the first statement?
If you want to write an array to a range, the array must have two dimensions. Even if you only wish to write a single column.
Change
ReDim arrayToWrite(1 To (lastCol - 2) * (lastRow - 1))
to
ReDim arrayToWrite(1 To (lastCol - 2) * (lastRow - 1), 1 To 1)
and
arrayToWrite(i + k) = budgets(i, j)
to
arrayToWrite(i + k, 1) = budgets(i, j)
simply use transpose... change
Ws.Range("E2").Resize(UBound(arrayToWrite)).Value = arrayToWrite
to
Ws.Range("E2").Resize(UBound(arrayToWrite)).Value = Application.Transpose(arrayToWrite)
Hint: there is no need for ReDim budgets(1 To lastrow - 1, 1 To lastcol - 2).
If budgets is a variant then budgets = Ws.Range("C2:AU265") will automatically set the ranges (upper left cell (in this case C2) will be (1, 1)).
EDIT
Assuming you only want to write down all columns (one after another) below each other, you can shorten the macro a bit like that:
Private Sub procedure()
Dim inArr As Variant, outArr() As Variant
Dim i As Long, j As Long, k As Long
With Sheet19
.Activate
inArr = .Range(, .Cells(2, 3), .Cells(.Cells.Find("*", , , , 1, 2).Row, .Cells.Find("*", , , , 2, 2).Column)).Value
End With
ReDim outArr(1 To UBound(inArr) * UBound(inArr, 2))
k = 1
For j = 1 To UBound(inArr, 2)
For i = 1 To UBound(inArr)
k = k + 1
arrayToWrite(k) = budgets(i, j)
Next i
Next j
Sheet6.Range("E2:E" & UBound(arrayToWrite)).Value = Application.Transpose(arrayToWrite)
End Sub
And if you want each row transposed and below each other than simply switch the two For...-lines. (Still the code does basically the same like before)