How to add a counter column to existing matrix in VBA? - arrays

How to get a new matrix in VBA with a counter value in the first "column". Suppose we have a VBA matrix which values we get from cells. The value of A1 cell is simply "A1".
Dim matrix As Variant
matrix = Range("A1:C5").value
Input matrix:
+----+----+----+
| A1 | B1 | C1 |
+----+----+----+
| A2 | B2 | C2 |
+----+----+----+
| A3 | B3 | C3 |
+----+----+----+
| A4 | B4 | C4 |
+----+----+----+
| A5 | B5 | C5 |
+----+----+----+
I would like to get new matrix with the counter value in the first column of VBA matrix.
Here are desired results:
+----+----+----+----+
| 1 | A1 | B1 | C1 |
+----+----+----+----+
| 2 | A2 | B2 | C2 |
+----+----+----+----+
| 3 | A3 | B3 | C3 |
+----+----+----+----+
| 4 | A4 | B4 | C4 |
+----+----+----+----+
| 5 | A5 | B5 | C5 |
+----+----+----+----+
One way to do it is looping. Would there be any other more elegant way to do it? We are dealing here with large data sets, so please mind the performance.

If your main concern is the performance, then use Redim Preserve to add a new column at the end and use the OS API to shift each column directly in the memory:
Private Declare PtrSafe Sub MemCpy Lib "kernel32" Alias "RtlMoveMemory" ( _
ByRef dst As Any, ByRef src As Any, ByVal size As LongPtr)
Private Declare PtrSafe Sub MemClr Lib "kernel32" Alias "RtlZeroMemory" ( _
ByRef src As Any, ByVal size As LongPtr)
Sub AddIndexColumn()
Dim arr(), r&, c&
arr = [A1:F1000000].Value
' add a column at the end
ReDim Preserve arr(LBound(arr) To UBound(arr), LBound(arr, 2) To UBound(arr, 2) + 1)
' shift the columns by 1 to the right
For c = UBound(arr, 2) - 1 To LBound(arr, 2) Step -1
MemCpy arr(LBound(arr), c + 1), arr(LBound(arr), c), (UBound(arr) - LBound(arr) + 1) * 16
Next
MemClr arr(LBound(arr), LBound(arr, 2)), (UBound(arr) - LBound(arr) + 1) * 16
' add an index in the first column
For r = LBound(arr) To UBound(arr)
arr(r, LBound(arr, 2)) = r
Next
End Sub

Method 1
This method inserts cells to the left of the range and set the new cells formula to calculate the counter =ROWS($A$1:$A5). Note: this pattern is also used to calculate a running total.
Usage
InsertCounter Worksheets("Sheet1").Range("A1:C5")
Sub InsertCounter(Target As Range)
Dim counterCells As Range
Target.Columns(1).Insert Shift:=xlToRight
Set counterCells = Target.Columns(1).Offset(0, -1)
counterCells.Formula = "=Rows(" & counterCells.Cells(1, 1).Address(True, True) & ":" & counterCells.Cells(1, 1).Address(False, True) & ")"
End Sub
Method 2
This method copies the Ranges' Values into an array, creates a new array with 1 extra column and then copies the data and a counter over to the new array. The difference in this Method is that it doesn't insert any cells.
Usage
AddCounterToMatrix Worksheets("Sheet1").Range("A1:C5")
Sub AddCounterToMatrix(Target As Range)
Dim x As Long, y As Long
Dim Matrix1 As Variant, NewMatrix1 As Variant
Matrix1 = Target.Value
ReDim NewMatrix1(LBound(Matrix1) To UBound(Matrix1), LBound(Matrix1, 2) To UBound(Matrix1, 2) + 1)
For x = LBound(Matrix1) To UBound(Matrix1)
NewMatrix1(x, 1) = x - LBound(Matrix1) + 1
For y = LBound(Matrix1, 2) To UBound(Matrix1, 2)
NewMatrix1(x, y + 1) = Matrix1(x, y)
Next
Next
Target.Resize(UBound(NewMatrix1) - LBound(Matrix1) + 1, UBound(NewMatrix1, 2) - LBound(NewMatrix1, 2) + 1).Value = NewMatrix1
End Sub

using a Dynamic variant is fast.
Sub test()
Dim matrix As Variant, newMatrix()
Dim i As Long, n As Long, c As Long, j As Long
matrix = Range("A1:C5").Value
n = UBound(matrix, 1)
c = UBound(matrix, 2)
ReDim newMatrix(1 To n, 1 To c + 1)
For i = 1 To n
newMatrix(i, 1) = i
For j = 2 To c + 1
newMatrix(i, j) = matrix(i, j - 1)
Next j
Next i
Range("a1").Resize(n, c + 1) = newMatrix
End Sub

excel based solution are ok for u?
Columns("A:A").Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Range("A1") = "1"
Range("A2") = "2"
Range("A1:A2").Select
Selection.AutoFill Destination:=Range("A1:A5")
Dim matrix As Variant
matrix = Range("A1:D5").Value

Why not a compromise between household remedies and pure array scripting by inserting a temporary column and doing the rest within the array's first column.
Code
Option Explicit
Public Sub test_CounterCol2()
Dim matrix As Variant, newMatrix()
Dim i As Long, n As Long
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("CounterCol") ' <== user defined sheet
' a) insert column temporarily]
ws.Columns("A:A").Insert Shift:=xlToRight
' b) get values
matrix = ws.Range("A1:D5").value
' c) only loop within array counter column
n = UBound(matrix, 1)
For i = 1 To n
matrix(i, 1) = i
Next i
' d) delete temporary insertion
ws.Columns("A:A").Delete (xlShiftToLeft)
End Sub
Additional note: Maybe you can find something via API (CopyMemory).

Related

vba loop through array, store values to arrayi

I have some data, stored in arrays like
Dim arrA, arrB, arrC, arrAi, arrBi
Dim i as integer, x as integer
for i = 1 to 100
if cells(i,1).value = "criteria" then ' just add value to array when it meets some criteria
x = x + 1
arrA(x) = cells(i,1).value
arrB(x) = cells(i,2).value
arrC(x) = cells(i,3).value
end if
next i
redim preserve arrA(1 to x)
redim preserve arrB(1 to x)
redim preserve arrC(1 to x)
And the data looks like
arrA: 26.1 40.2 80.3 26.0 41.3 78.7 25.8 40.8 80.0
arrB: 10 11 10 66 67 64 32 32 33
arrC: 1 2 3 1 2 3 1 2 3
Since the values in arrA 26.1, 26.0, 25.8 (position 1, 4, 7) belong to group 1 (referencing to values in arrC at same position), I would like to store 26.1 26.0 25.8 to arrAi and 10 66 32 to arrBi for subsequent calculations.
How can I loop through the 3 arrays and store values to another array as described above?
Thanks in advance.
Try the next way, please:
Sub handleArraysFromArrays()
'your existing code...
'but you fistly must declare
Dim arrA(1 To 100), arrB(1 To 100), arrC(1 To 100)
'....
'your existing code
'...
Dim k As Long, kk As Long
ReDim arrAi(1 To UBound(arrA))
ReDim arrBi(1 To UBound(arrA))
For i = 1 To UBound(arrC)
If arrC(i, 1) = 1 Then k = k + 1: arrAi(k, 1) = arrA(i, 1)
If arrC(i, 1) = 2 Then kk = kk + 1: arrBi(kk, 1) = arrA(i, 1)
Next i
ReDim Preserve arrAi(1 To k): ReDim Preserve arrBi(1 To kk)
Debug.Print UBound(arrAi), UBound(arrBi)
End Sub

Pasting VBA Array into Excel Range

I know this question has been asked multiple times, but I am kinda stuck adopting the suggested solutions to my problem.
I have an array(0 to 4), that gets filled multiple times in a loop and should be pasted each time into a new line in excel.
Expected Output:
A | B | C | D | E
1 X1 | X2 | X3 | X4 | X5
My code:
r i = 0 To iVal
Dim infoarr(0 To 4) As Variant
infoarr(0) = ws_src_agv.Cells(ref + i + 3, 2).Value
infoarr(1) = ws_src_agv.Cells(ref + i + 4, 2).Value
infoarr(2) = ws_src_agv.Cells(ref + i + 3, 1).Value
infoarr(3) = ws_src_agv.Cells(ref + i + 3, 3).Value
infoarr(4) = ws_src_agv.Cells(ref + i + 3, 7).Value
lastR = ws_tgt_agv.Rows(Rows.Count).End(xlUp).Row
'First attempt:
ws_tgt_agv.Range(ws_tgt_agv.Cells(lastR + 1, 1), ws_tgt_agv.Cells(lastR + 1, 5)).Value = WorksheetFunction.Transpose(infoarr)
Output:
A | B | C | D | E
1 X1 | X1 | X1 | X1 | X1
2nd attempt:
ws_tgt_agv.Cells(lastR + 1, 1).Resize(UBound(infoarr, 1) + 1).Value = WorksheetFunction.Transpose(infoarr)
Ouput:
A | B | C | D | E
1 X1 | | | |
2 X2
3 X3
4 X4
5 X5
if leaving the transpose argument at the end the same range gets filled with sloley X1.
Thanks for your help!
A 1-D array (both zero based and one based) is aligned like a single row with multiple columns. You don't need to transpose in order to put te array's values into the worksheet; you only need the correct size of target.
with ws_tgt_agv
.Range(.Cells(lastR + 1, 1), .Cells(lastR + 1, 5)).Value = infoarr
end with
If you want to put the array's values into a single column of multiple rows then you need to transpose.
with ws_tgt_agv
.Range(.Cells(lastR + 1, 1), .Cells(lastR + 6, 1)).Value = Application.Transpose(infoarr)
end with

Excel-VBA - Insert new first column in datafield array without loops or API calls

Intro
Last year #PrzemyslawRemin posed the question how to add a counter column to an existing matrix in VBA without additional loops and without modifying a worksheet.
The original matrix in this example was a (1-based 2-dim) datafield array resulting from (source cells simply contain their address strings; the inserted row to be filled with numbers)
Dim matrix As Variant
matrix = Range("A1:C5").value
Input matrix: ------------ ▼ Desired result:
+----+----+----+ +----+----+----+----+
| A1 | B1 | C1 | | 1 | A1 | B1 | C1 |
+----+----+----+ +----+----+----+----+
| A2 | B2 | C2 | | 2 | A2 | B2 | C2 |
+----+----+----+ +----+----+----+----+
| A3 | B3 | C3 | | 3 | A3 | B3 | C3 |
+----+----+----+ +----+----+----+----+
| A4 | B4 | C4 | | 4 | A4 | B4 | C4 |
+----+----+----+ +----+----+----+----+
| A5 | B5 | C5 | | 5 | A5 | B5 | C5 |
+----+----+----+ +----+----+----+----+
Of course the idea suggesting itself is to use a redimmed newMatrix as Dy.Lee proposed, but this would include two loops to shift rows and columns:
Sub test()
Dim matrix As Variant, newMatrix()
Dim i As Long, n As Long, c As Long, j As Long
matrix = Range("A1:C5").Value
n = UBound(matrix, 1)
c = UBound(matrix, 2)
ReDim newMatrix(1 To n, 1 To c + 1)
For i = 1 To n
newMatrix(i, 1) = i
For j = 2 To c + 1
newMatrix(i, j) = matrix(i, j - 1)
Next j
Next i
Range("a1").Resize(n, c + 1) = newMatrix
End Sub
Another work around avoiding unnecessary loops would be to write the array back to a temporary worksheet starting at column B and collect the data from there again including column A:D, but this means modifying a worksheet.
Florent B. alone solved the problem via extremely fast API calls using MemCopy and there appeared no other approach since. - So for principal reasons it is of some interest if this should be the ultima ratio or if there can be found another approach.
► Modified question (No duplicate!)
Is there any possibility to insert a new first "column" in the existing datafield array
without loops over "rows" and "columns" to shift the existing values,
without worksheet modifications and
without API calls using VBA?
Different from Prezmyslaw's OP I'm not using huge data sets, so that a limitation to approximately 64k rows would be possible (c.f. max. transposing limitation).
Found solution via the Application.Index function
I found a solution simply by trying out some unusual variations of the Application.Index function which I try to resume as a comprehensive generic overview to demonstrate the rich range of application. So any helpful addition is welcome (c.f. #chrisneilsen 's comment).
Some peculiarities of the the Application.Index function
Typically the index function would deliver a well defined item by its row and column position, but there are some not so widely known pecularities:
Similarly to the Worksheet.Index function you can get the entire column or row items if the row or column number argument is set to zero (0). - Another frequently unknown way to create a 2-dim array by passing a double-zero parameter can be found at How to initialize a 2-dim array in Excel VBA
Use of array arguments possible - This function allows not only the known index indications by given numbers, but also array parameters to extract "rows" or "columns", so it's possible to indicate a wanted set of columns, e.g.A:C via Array(1,2,3) as column array argument.
Filtering effects - Furthermore I learnt that it is possible to reduce the choice to some columns (rows) only, e.g. via Array(1,3) and even to change the internal order, e.g. Array(3,2,1)`.
Restructuring - The most surprising fact, however, is that it is possible to repeat a column choice, e.g. via Array(1,1,2,3)
or even Array(0,1,2,3) where the 0 item is the same as column 1. This can be used to reach the same effect as a column insertion.
This last restructuring capability of the mentioned Index function is the key part of my approach:
Code example
Sub AddFirstIndexColumn()
Dim v, i&, ws As Worksheet
Set ws = ThisWorkbook.Worksheets("SourceSheet") ' << change to source sheet name
' [1] get data
v = ws.[A1:C5].Value2
' [2] define column array inserting first column (0 or 1) and preserving old values (1,2,3)
v = Application.Index(v, _
Application.Evaluate("row(1:" & UBound(v) & ")"), _
Array(0, 1, 2, 3)) ' columns array where 0 reinserts the first column
' [3] add an current number in the first column
For i = LBound(v) To UBound(v): v(i, 1) = i: Next i
End Sub
How to test the result
Just insert the following to the code above:
' [4a] test result by debugging in immediate window
For i = LBound(v) To UBound(v)
Debug.Print "#" & i & ": " & Join(Application.Index(v, i, 0), ", ")
Next i
' [4b] test result by writing back to target sheet
Dim ws2 As Worksheet
Set ws2 = ThisWorkbook.Worksheets("TargetSheet") ' << change to target sheet name
ws2.Range("A1").Resize(UBound(v), UBound(v, 2)).Offset(0, 0) = v
Caveat
The found solution seems to be restricted to 65536 rows (possibly similar to array transposing limitation), so that you can't use it for bigger data.
Some recent Application.Index examples
Copy from sheet1 columns A,B,C,G,F,R,S,T to sheet2 in columns A,B,C,D,E,F,G,H
Multi criteria selection with VBA
How to join returned values from named range separated by comma

Copy non-contiguous columns into into a multi-dimension array?

I'm trying to copy values from one sheet to another, comparing the Key values (columns A & C) and either pasting a value (column E) into the target sheet or adding a row and pasting all three values into A, C, F.
Here's a sample of the data:
SOURCE TABLE
A B C D E
Name Ext Dept Days w22Hrs
------- ------- ------- ------- -------
Alan x101 Level1 MTWTF 8
Brian x102 Level1 MTWTF 30
Claire x103 Level1 MTWTF 40
Denise x104 Level2 MTWTF 16
Denise x105 Level1 MTWTF 24
TARGET TABLE
A B C D E F
Name Ext Dept Days w21Hrs w22Hrs
------- ------- ------- ------- ------- -------
Brian x102 Level1 MTWTF 32
Denise x104 Level2 MTWTF 16
Denise x105 Level1 MTWTF 8
Eric x106 Level1 MTWTF 36
DESIRED RESULT
A B C D E F
Name Ext Dept Days w21Hrs w22Hrs
------- ------- ------- ------- ------- -------
Alan Level1 0 8
Brian x102 Level1 MTWTF 32 30
Claire Level1 0 40
Denise x104 Level2 MTWTF 16 16
Denise x105 Level1 MTWTF 8 24
Eric x106 Level1 MTWTF 36 0
I tried to copy the source data into an array using this code:
set rng = union(range("A2:A6"), range("C2:C6"), range("E2:E6"))
arrTemp = rng.value2
arr = application.transpose(arrTemp)
But all I get is are values from A2:A6. However this works:
set rng = range("A2:E6")
arrTemp = rng.value2
arr = application.transpose(arrTemp)
1 - Is there no easy way to put only the columns I want into the array? (Iterating through cell areas seems inelegant to me.)
2 - Is there an easier way to accomplish the overall goal of updating the target sheet? (Keep in mind I want to update w##Hrs for existing rows AND add new rows when needed.) Or are arrays my best bet? (Would a Collection be better?)
If it makes things easier, I can paste A:D into the target, but source.E still needs to go into target.F.
Thanks!
A collection would work but I prefer to use a Scripting Dictionary. Scripting Dictionaries have an Exists method that you can use to see if a Key exists already, collections don't. When adding Keys to a collection you'll have to escape any errors caused by trying to add a duplicate key.
Sub UpdateTargetTable()
Dim k As String
Dim lastRow As Long, x As Long
Dim dict As Object
Dim arr
Set dict = CreateObject("Scripting.Dictionary")
With Worksheets("Source")
lastRow = .Range("A" & Rows.Count).End(xlUp).Row
For x = 2 To lastRow
k = .Cells(x, 1) & .Cells(x, 2)
If Not dict.Exists(k) Then
dict.Add k, .Range(.Cells(x, 3), .Cells(x, 5)).Value
End If
Next
End With
With Worksheets("Target")
lastRow = .Range("A" & Rows.Count).End(xlUp).Row
For x = 2 To lastRow
k = .Cells(x, 1) & .Cells(x, 2)
If dict.Exists(k) Then
arr = dict(k)
.Cells(x, 3) = arr(1, 1)
.Cells(x, 4) = arr(1, 2)
.Cells(x, 6) = arr(1, 3)
End If
Next
End With
End Sub

Input/output values into an array

EDIT: Updated question using some of the suggestions below. This produces weird output though.
Dim ProviderArray() As Variant
Sub GetProviderNumbers()
Dim InputRange As Range
Dim WorkRange As Range
Set InputRange = Range("ProviderList")
Set WorkRange = Application.Intersect(InputRange, ActiveSheet.UsedRange)
SizeOfArray = Application.WorksheetFunction.CountA(WorkRange)
ReDim ProviderArray(0 To SizeOfArray)
ProviderArray = WorkRange.Value
For r = 1 To UBound(ProviderArray, 1)
For C = 1 To UBound(ProviderArray, 2)
Debug.Print r, C, ProviderArray(r, C)
Next C
Next r
End Sub
1 1 5555
2 1 4444654
3 1 654654
4 1 654654654
5 1
6 1
7 1
8 1
9 1
10 1
11 1
12 1
13 1
14 1
15 1
16 1
17 1
18 1
19 1
Could someone explain why this output?
You can only use the one-line approach if you put the range into a 2-D array: you only have a 1-D array.
You could do this:
Dim ProviderArray()
Set WorkRange = .Intersect(InputRange, ActiveSheet.UsedRange)
'This makes ProviderArray a 2-D array, dimension 1 = # rows,
' dimension2 = #cols. Both dimensions are 1-based.
ProviderArray = WorkRange.value
for r=1 to ubound(ProviderArray,1)
for c=1 to ubound(ProviderArray,2)
debug.print r,c,ProviderArray(r,c)
next c
next r
Maybe something a bit simpler like:
Private Sub GetProviderNumbers()
Dim InputRange() As Variant
InputRange = Range("ProviderList")
For Each i In InputRange
Debug.Print i
Next
End Sub
This captures a two-dimensional range and stores the values in a global two-dimensional array:
Dim ProviderArray() As String
Sub MAIN()
Range("B2:C11").Name = "ProviderList"
Call GetProviderNumbers
End Sub
Sub GetProviderNumbers()
ary = Range("Providerlist")
ll = LBound(ary, 1)
lm = LBound(ary, 2)
ul = UBound(ary, 1)
um = UBound(ary, 2)
ReDim ProviderArray(ll To ul, lm To um)
For i = ll To ul
For j = lm To um
ProviderArray(i, j) = ary(i, j)
Next
Next
End Sub

Resources