I’m in a situation where I need to reproduce something in VBA and a bit stuck given my lack of understanding of object oriented language and VBA in general.
Problem:
I need to produce an array or vector based on a 2 column table.
The first range (column) contains unit counts.
The second range (column) contains numeric values.
I need to replicate the value based on the number of units.
For example,
if the first row contains 3 units with a value of $100
I need the array to contain $100, $100, $100.
This will need to be looped thru each row containing units.
So if row 2 contains 2 units with a value of $50
I need to complete array to be $100, $100, $100, $50, $50, and so on.
I understand this situation will require ReDim the array based on the total values. My struggle is I’ve been unable to figure out the nested for loops.
I get how to replicate the value based on the number of “units” like the below...
ReDim arr(0 To x - 1)
For i = 0 To x - 1
arr(i) = rng.Offset(0, 1).Value
Next
What is the best way to loop thru each row and replicate the values for each row in the range based on the unit count?
If anyone is familiar with R, I'm essentially looking for something that achieves the rep() function (e.g., rep(df$b, df$a)) and return the values in a single array.
Any help is greatly appreciated. Thanks
Or a one liner which uses the REPT function as you would have used in r :)
This assumes your data is in A1:B10 - the length can be made variable
s = Split(Join(Application.Transpose(Evaluate("=INDEx(REPT(B1:B10&"","",A1:A10),,1)"))), ",")
An an example, to dump the new to array to C1
s = Split(Join(Application.Transpose(Evaluate("=INDEx(REPT(B1:B10&"","",A1:A10),,1)"))), ",")
[c1].Resize(UBound(s), 1) = Application.Transpose(s)
When you say Row contains 3 units, do you mean the cell has value 3 or 3 Units? If it is 3 then you may not have to Redim the array in the loop. Simply find the sum of values in Col A which has units and Redim it in one go as shown below.
Sub Sample()
Dim ws As Worksheet
Dim Ar() As String
Dim n As Long, i As Long, lRow As Long
'~~> Change this to the relevant sheet
Set ws = Sheet6
With ws
n = Application.WorksheetFunction.Sum(.Columns(1))
ReDim Ar(t To n)
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
n = 1
For i = 1 To lRow
If Len(Trim(.Range("A" & i).Value)) <> 0 Then
For j = 1 To .Range("A" & i).Value
Ar(n) = .Range("B" & i).Value
n = n + 1
Next j
End If
Next i
For i = LBound(Ar) To UBound(Ar)
Debug.Print Ar(i)
Next i
End With
End Sub
Screenshot
And if the cell has 3 Units then you will have to store the values of Col A in an array, do a replace on Unit/Units, find the sum and finally use the above code. Here is an example
Sub Sample()
Dim ws As Worksheet
Dim Ar() As String, tmpAr As Variant
Dim n As Long, i As Long, j As Long, k As Long, lRow As Long
'~~> Change this to the relevant sheet
Set ws = Sheet6
With ws
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
tmpAr = .Range("A1:A" & lRow).Value
For i = LBound(tmpAr) To UBound(tmpAr)
tmpAr(i, 1) = Replace(tmpAr(i, 1), "Units", "")
tmpAr(i, 1) = Trim(Replace(tmpAr(i, 1), "Unit", ""))
n = n + Val(tmpAr(i, 1))
Next i
ReDim Ar(t To n)
n = 1
For i = 1 To lRow
If Len(Trim(.Range("A" & i).Value)) <> 0 Then
k = Val(Trim(Replace(Replace(.Range("A" & i).Value, "Units", ""), "Unit", "")))
For j = 1 To k
Ar(n) = .Range("B" & i).Value
n = n + 1
Next j
End If
Next i
For i = 1 To UBound(Ar)
Debug.Print Ar(i)
Next i
End With
End Sub
Screenshot
if your data is already in an array then ReDim'ing will delete it's contents. You can ReDim Preserve but it's an expensive operation, better to create a new array to put the results into.
I have assumed the data is contained within a Named Range called "Data" with Units being the first column and Values being the second column.
if your data changes regularly you can create a dynamic range using the OFFSET function i.e. =OFFSET(Sheet1!$A$1,0,0,COUNTA(Sheet1!$A:$A),2) assuming your data starts in cell A1 and there is no header row.
Sub ProcessData()
Dim DataArr() As Variant
Dim QtyColArr() As Variant
Dim ResultArr() As Variant
Dim TotalQty As Long
Dim i As Long, j As Long, k As Long
'store data into array
DataArr = Range("Data") 'assume data stored in named range called "Data"
'store Qty col into 1D array
QtyColArr = Range("Data").Resize(, 1)
'sum all qty vals
TotalQty = Application.Sum(QtyColArr)
're-size ResultsArray
ReDim ResultArr(1 To TotalQty)
'Initialize ResultsArr counter
k = LBound(ResultArr)
'loop DataArr
For i = LBound(DataArr) To UBound(DataArr)
'loop qty for current row
For j = 1 To DataArr(i, 1)
'copy value
ResultArr(k) = DataArr(i, 2)
'iterate ResultsArr counter
k = k + 1
Next j
Next i
'output to intermediate window
Debug.Print "{" & Join(ResultArr) & "}"
End Sub
Related
Suppose I have a VBA one dimension array (or dict or collection) with X values. I need to perform an action with these values in batches of Y.
So if X = 55 and Y = 25, I would need to loop 3 times:
Pick values 1 to 25 and perform action
Pick values 26 to 50 and perform action
Pick last 5 values and perform action
Any ideas with good performance will be greatly appreciated :)
Edit:
I came up with the code below. It works although doesn't look very concise
Sub test()
Dim arr As Variant
Dim temparr As Variant
Dim sippno As Integer
Dim loopend As Integer
Dim loopstart As Integer
Dim batchsize As Integer
Dim i As Integer
'Storing main array with all values
arr = Sheet1.Range("A1:A" & Sheet1.Range("A" & Rows.Count).End(xlUp).Row).Value
'Setting count of values, batch size and starting step for loop
sippno = WorksheetFunction.CountA(arr)
loopstart = 1
batchsize = 10
Do Until sippno = 0
If sippno < batchsize Then
loopend = loopstart + sippno - 1
Else
loopend = loopstart + batchsize - 1
End If
ReDim temparr(loopstart To loopend)
For i = loopstart To loopend
temparr(i) = WorksheetFunction.Index(arr, i, 0)
sippno = sippno - 1
Next
loopstart = loopend + 1
'Action to be performed with batch of values stored in second array
Debug.Print WorksheetFunction.TextJoin(", ", True, temparr)
Loop
End Sub
Slicing via Application.Index()
Just for the sake of the art I demonstrate in this late post how to slice a 'vertical' array in one go into several 'flat' arrays in batches of e.g. 10 elements.
This approach benefits from the advanced rearranging features & pecularities of Application.Index()
allowing to pass entire row/column number arrays as arguments; here suffices a vertical array of desired row numbers, e.g. by filtering only rows 11 to 20 via Application.Index(data, Evaluate("Row(11:20)"), 0). .. c.f. see section 2 a)
Further notes:
evaluating a tabular row formula is one quick way to get consecutive row numbers.
transposing the function result changes the array dimension to a 1-dim array
reducing the array boundaries by -1 via ReDim Preserve ar(0 To UBound(ar) - 1) produces a zero-based array (optional)
Option Explicit
Sub splice()
Const batch = 10 ' act in units of 10 elements
With Sheet1
'1) get data (1-based 2-dim array)
Dim lastRow As Long
lastRow = .Cells(Rows.Count, "A").End(xlUp).Row
Dim data: data = .Range("A1:A" & lastRow).Value2
'2) slice
Dim i As Long, nxt As Long, ar As Variant
For i = 1 To UBound(data) Step batch
nxt = Application.min(i + batch - 1, UBound(data))
'2a) assign sliced data to 1- dim array (with optional redim to 0-base)
With Application
ar = .Transpose(.Index(data, Evaluate("row(" & i & ":" & nxt & ")")))
End With
'optional redimming to zero-base
ReDim Preserve ar(0 To UBound(ar) - 1)
'2b) perform some action
Debug.Print _
"batch " & i \ batch + 1 & ": " & _
"ar(" & LBound(ar) & " To " & UBound(ar) & ") ~~> " & _
Join(ar, "|")
Next
End With
End Sub
Slicing a 'flat' 1-dim array
If, however you want to slice a 1-dim array, like e.g. dictionary keys, it suffices to transpose the data input: data = Application.Transpose(...)
Option Explicit
Sub splice()
Const batch = 10
Dim data, ar()
Dim lastrow As Long, n As Long, i As Long
Dim j As Long, r As Long
With Sheet1
lastrow = .Cells(Rows.Count, "A").End(xlUp).Row
data = .Range("A1:A" & lastrow).Value2
End With
i = Int(lastrow / batch)
For n = 0 To i
r = batch
If n = i Then
r = lastrow Mod batch
End If
If r > 0 Then
ReDim ar(r - 1)
For j = 1 To r
ar(j - 1) = data(j + n * batch, 1)
Next
' do something
Debug.Print Join(ar, ",")
End If
Next
End Sub
2d array because to lazy to encode 1d but same idea with 1d:
Sub test()
arr = Sheet3.Range("A1").CurrentRegion.Value2
x = UBound(arr)
y = 5
jj = y
For j = 1 To UBound(arr)
sumaction = sumaction + arr(j, 1)
If (UBound(arr) - jj) < 0 Then
jj = UBound(arr)
sumaction = 0
End If
If j = jj Then
dosomething = sumaction * 2
sumaction = 0
jj = jj + y
End If
Next j
End Sub
i have a multidimensional dynamic array with 11 columns.
how do i count how many elements in column 4 starts with "ZS" (there can be items with no value, other with "ZC973279473" and others with "ZS5367276". i care only about the one like "ZS773746".)
i tried with
XNSites = Application.Count(Application.Match(Left(myarray.Columns(4), 2), "ZS", 0))
and
XNSites = Application.WorksheetFunction.CountIf(Left(myarray.columns(4), 2), "=" & "ZS")
but it doesn't work
Since your data seems to be alphanumeric, with just the first two chars as letters, you could prevent a loop using a 1D-array extract from a 2D-array when you apply FILTER:
Sub Test()
Dim arr1 As Variant, arr2 As Variant, arr3 As Variant
Dim lr As Long
With Sheet1 'Change to your own sheets CodeName
'Fill dynamic 2D-array for testing (not sure how you get your array)
lr = .Cells(.Rows.Count, 1).End(xlUp).Row
arr1 = .Range("A1:K" & lr).Value2
'Get you 1D-array for the 4th column
With Application
arr2 = .Transpose(.Index(arr1, 0, 4))
End With
'Count elements starting with ZS
arr3 = Filter(arr2, "ZS")
Debug.Print UBound(arr3) + 1
End With
End Sub
I think a simple iteration will help you:
Dim Count As Long
Dim ColCell As Range
For Each ColCell In myarray.Columns(11).Cells
If Left(ColCell.Value, 2) = "ZS" Then
Count = Count + 1
End If
Next ColCell
Debug.Print "Total: " & Count
Please try below code( I believe all you care about values in column 4). This code will
copy the entire rows which have ZS values at the beginning in column 4 and paste it on sheet2
If data is not on sheet1,please change the sheetname :)
Sub you()
lfr = ThisWorkbook.Worksheets("sheet1").Cells(Rows.Count, 1).End(xlUp).Row
For x = 2 To lfr
If Worksheets("sheet1").Cells(x,4).Value Like "ZS*" Then
Worksheets("sheet1").Rows(x).Copy
Worksheets("sheet2").Activate
bfr = ThisWorkbook.Worksheets("sheet2").Cells(Rows.Count, 1).End(xlUp).Row
Worksheets("sheet2").Cells(bfr + 1, 1).Select
ActiveSheet.Paste
End If
Next
Application.CutCopyMode = False
Worksheets("sheet1").Activate
Worksheets("sheet1").Cells(1, 1).Select
End Sub
If you want just the count try below(You please change rahge from gi to wherever you want the count number) :-
Sub you()
lfr = ThisWorkbook.Worksheets("sheet1").Cells(Rows.Count, 1).End(xlUp).Row
For x = 2 To lfr
KLA = Application.WorksheetFunction.Count(Worksheets("sheet1").Cells(x, 4).Value Like "ZS")
Range("g1") = KLA
Next
End Sub
I'm trying to analyze some data from a worksheet, the first step was to find the last row, which I managed. Then I need to store the data in an array for each column to simplify further analysis.
My data looks like this:
I'm trying to store let's say the B column in an array but starting at B6:
Sub List_Rem_stock()
Dim array_Rem_Batch(1 To last_row_Rem_stock - 5) As Integer
For i = 1 To last_row_Rem_stock - 5
array_Rem_Batch(i) = Worksheets("Rem stock").Range(Bi)
Next i
Debug.Print array_Rem_Index
End Sub
last_row_Rem_stock represents the last row of the table.
Am I doing this properly?
Almost, try the code below (find explanation inside code's comments):
Option Explicit
Sub List_Rem_stock()
Dim last_row_Rem_stock As Long, i As Long
Dim array_Rem_Batch() As Long
With Worksheets("Rem stock")
last_row_Rem_stock = .Cells(.Rows.Count, "B").End(xlUp).Row ' get last row with value in colum B
ReDim array_Rem_Batch(1 To last_row_Rem_stock - 5) ' redim array size
For i = 1 To last_row_Rem_stock - 5
array_Rem_Batch(i) = .Range("B" & i).Value
Next i
End With
End Sub
You can allocate a range to an array (2D) as such:
Dim arrData as variant: arrData = Range("B1:B" & lastrow).
You can also put the array back on the spreadsheet the same way:
Range("B1:B" & lastrow) = arrData
Simple, easy and fast, without the need of iterating through data.
In your example, you would probably do it like this.
Sub List_Rem_stock()
Dim i As Long, last_row_Rem_stock As Long
Dim array_Rem_Batch As Variant
With Worksheets("Rem stock")
last_row_Rem_stock = .Cells(.Rows.Count, "B").End(xlUp).Row 'get last row in B
array_Rem_Batch = .Range("B1:B" & last_row_Rem_stock)
End With
For i = 6 To last_row_Rem_stock
Debug.Print array_Rem_Batch(i, 1)
Next i
End Sub
To note that arrays allocated this way will always start at 1, not 0.
EDIT:
I'm allocating the data starting at row 1, and not at row 6, purely for the nice 1:1 relation between array index and sheet rows. Is my prefered way, wherever the situation allows.
If array_Rem_Batch(i, 1) = Range("B" & i) Then ....
Can always allocate the data from any row you want:
array_Rem_Batch = Worksheets("Rem stock").Range("B6:B100") 'now the array has 95 rows.
In this case, array index 1, will corespond to row 6 in the sheet, and will have to manage this in the code if you need to something like this:
If array_Rem_Batch(i, 1) = Range("B" & i + 5) Then ....
I'm writing a sub in VBA that is trying to look at each element in one array and see if it shows up in another array. The first array is in rows A2:A325 in Sheet A, and the second array is over 250,000 values. I keep getting a runtime error 9: subscript out of range. My code is below
Private Sub ICD_DRG_Converter()
Dim StudyDRG() As Variant
Dim StudyICD10() As Variant
Dim element As String
Dim lLastRow, i, j, k As Long
Dim ICD10Code As String
Worksheets("Accepted DRG's").Activate
ReDim StudyDRG(1 To 325) As Variant
StudyDRG = Range("A2:A325") 'Populate the study DRG's into an array for comparison
Worksheets("full_appendix_B").Activate
lLastRow = ActiveSheet.Cells(Rows.Count, "B").End(xlUp).Row 'get the last row of data for sizing our ICD 10 array
ReDim StudyICD10(1 To (lLastRow)) As Variant
StudyICD10 = Range("B2:B" & lLastRow)
'i = 0
For i = LBound(StudyICD10) To UBound(StudyICD10)
k = 1
For j = LBound(StudyDRG) To UBound(StudyDRG)
If StrComp(StudyICD10(i), StudyDRG(j), vbBinaryCompare) = 0 Then 'match between study DRG and ICD-10 DRG
Worksheets("full_appendix_B").Activate
ICD10Code = Range("A" & j).Value
Worksheets("Accepted ICD-10").Activate
Range("A" & k) = ICD10Code
k = k + 1
Exit For
End If
Next j
Next i
End Sub
The line that generates the error is:
If StrComp(StudyICD10(i), StudyDRG(j), vbBinaryCompare) = 0 Then
Any help on how to fix this would be appreciated. I've tried everything I know
When you use Range() to return a range of values into a variant array, the array is resized to match the range. So the results of
ReDim StudyDRG(1 To 325) As Variant
StudyDRG = Range("A2:A325")
is that studyDRG will have elements from 1 to 324, not 1 to 325.
Not only that, but Range() always returns a two dimensional array, even if there's only one column. So to refer to the element that corresponds to A2, you need to use StudyDRG(1,1), and A3 would be StudyDRG(1,2).
I hope this helps.
I have an excel sheet that is formatted like so:
I would like to format it to be something like this:
It is about 40,000 cells of information, so is there any way to do this that isn't manually?
You could probably use =SUMIF to achieve this, since you appear to have numbers as values.
Create a new sheet, copy column A from your data sheet to your new sheet and remove duplicates. Copy row 1 from your data sheet to your new sheet.
Use this formula in sheet 2 cell B2:
=SUMIF(Sheet1!$A:$A;Sheet2!$A2;Sheet1!B:B)
Drag the formula to the right, then down.
I am by no means an excel expert, and this is going to be my first answer ever. Take this into account please.
I've checked it and it works.
I've add a command button in Sheet1 (where the original data is), and when clicked this code writes formatted data into Sheet2.
No need to manually remove duplicates!
Dim dU1 As Object, cU1 As Variant, iU1 As Long, lrU As Long
Dim MyArray() As Variant
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim h As Integer
Private Sub CommandButton1_Click()
'Get unique indexes
Set dU1 = CreateObject("Scripting.Dictionary")
lrU = Cells(Rows.Count, 1).End(xlUp).Row 'number of rows
cU1 = Range("A2:A" & lrU) 'Assuming your data starts in A2
For iU1 = 1 To UBound(cU1, 1)
dU1(cU1(iU1, 1)) = 1
Next iU1
'Now dU1 contains indexes as unique values (about, absence, etc.)
For i = 0 To dU1.Count - 1 'for each index
ReDim MyArray(1 To 1) As Variant 'starts a "new" array
For j = 2 To 9 'each of the columns with values (D1-D8)
a = 0
For k = 2 To lrU 'all rows
If (Worksheets("Sheet1").Cells(k, 1).Value = dU1.keys()(i) And Worksheets("Sheet1").Cells(k, j).Value <> "") Then
MyArray(UBound(MyArray)) = Worksheets("Sheet1").Cells(k, j).Value 'add value to array
ReDim Preserve MyArray(1 To UBound(MyArray) + 1) As Variant 'resize array (now is 1 element longer)
a = a + 1
End If
Next
If a = 0 Then 'if no value found, add an element to array anyway
MyArray(UBound(MyArray)) = "" 'add value to array
ReDim Preserve MyArray(1 To UBound(MyArray) + 1) As Variant 'resize array (now is 1 element longer)
End If
Next
Worksheets("Sheet2").Cells(i + 2, 1) = dU1.keys()(i) 'write indexes in another sheet
For h = 2 To UBound(MyArray)
Worksheets("Sheet2").Cells(i + 2, h) = MyArray(h - 1)
Next
Next
End Sub