Do a loop with multiple constant condition VBA - excel

I am trying to do a loop but I'm a little stuck.
Sub Macro()
Range("A392: A401").Value = Range("N2")
Range("A402: A411").Value = Range("N3")
Range("A412: A421").Value = Range("N4")
Range("A422: A431").Value = Range("N5")
....
I need to repeat this logic ( On column A to set a value for each 10 rows) this value will be from Column N from 1 to 1 until it finds an empty row ...
I'm not being able to do the loop with these multiples conditions, would you please help me ?
Thanks a lot!

Range.Offset is a great method to manipulate ranges. Using it, we can automate the ranges to move down the sheet with each loop.
Sub Macro()
Dim i As Long
While Range("N2").Offset(i) <> ""
'Offset will shift N2 down by one each loop
'Offset will shift the 10 cell range down by 10 on each loop
Range("A392: A401").Offset(i * 10).Value = Range("N2").Offset(i)
i = i + 1
Wend
End Sub

I'm not quite sure what's your actual intention:
Repeat all values in column N2:N5 10 times and append the whole data block to the first free cell in column A.
Repeat all non-empty values in column N 10 times and write them to a fixed target starting with cell A392.
In both cases you can prefill an array and write it to the defined target in column A. Looping through an array has some speed advantages whereas looping through a range by means of VBA can be time consuming.
The direct (untested) copying of whole blocks as shown by #Toddleson can improve this behaviour, depending on total range sizes.
Case 1
Sub Example1()
Const RowsCount As Long = 10
With Sheet1 ' << change to your project's sheet (Code)Name
'get values to repeat & count them
Dim vals: vals = .Range("N2:N5")
Dim cnt As Long: cnt = UBound(vals)
'provide for 1-based 2-dim results array
Dim results
ReDim results(1 To RowsCount * cnt, 1 To 1)
'fill array with repeated values
Dim i As Long, j As Long
For i = 1 To cnt
For j = 1 To RowsCount
results((i - 1) * RowsCount + j, 1) = vals(i, 1)
Next j
Next i
'append above data block
Dim nxtRow As Long
nxtRow = .Range("A" & .Rows.Count).End(xlUp).Row + 1
.Range("A" & nxtRow).Resize(UBound(results), 1) = results
End With
End Sub
Case 2
Sub Example2()
Const RowsCount As Long = 10
With Sheet1 ' << change to your project's sheet (Code)Name
'get values to repeat & count them
Dim lastRow As Long
lastRow = .Range("N" & .Rows.Count).End(xlUp).Row
Dim vals: vals = .Range("N2:N" & lastRow)
Dim ValsCount As Long: ValsCount = UBound(vals)
'provide for 1-based 2-dim results array
Dim results
ReDim results(1 To RowsCount * ValsCount, 1 To 1)
'fill array with repeated values
Dim i As Long, j As Long, ii As Long
For i = 1 To ValsCount
If Len(vals(i, 1)) > 0 Then ' check if non-empty value in column N
ii = ii + 1
For j = 1 To RowsCount
results((ii - 1) * RowsCount + j, 1) = vals(i, 1)
Next j
End If
Next i
'write data block to fixed target starting with A392
.Range("A392").Resize(UBound(results), 1) = results
End With
End Sub

Related

Get the Row Positions without Looping

Is it possible to get the row positions in a large table in excel without performing a loop?
What I am trying to do is to click on a particular ID, and then the last 3 records from the same ID will be shown in UI.
I am beginner in programming and have no idea how to do this aside from looping method (which is very resource and memory-intensive considering we are looping a large and growing table of 100k rows in every single click from user).
For example: If user is clicking "A123" then we know that their row positions are : 5, 8 , 10
Same as CDP1802 posted but faster finding of last 3 rows.
Sub FilteredAdvanced()
Const nValues As Long = 3 'amount of rows you want to find from the end
Dim ar() As Long
ReDim ar(nValues - 1) As Long
' apply filter
With Sheet1
.AutoFilterMode = False
.UsedRange.AutoFilter 1, "A123"
Dim rng As Range
Set rng = .UsedRange.Columns(1).SpecialCells(xlCellTypeVisible)
.UsedRange.AutoFilter 'remove filter
End With
Dim n As Long
n = nValues - 1
Dim iArea As Long
For iArea = rng.Areas.Count To 1 Step -1
Dim iRow As Long
For iRow = rng.Areas(iArea).Rows.Count To 1 Step -1
ar(n) = rng.Areas(iArea).Rows(iRow).Row
n = n - 1
If n < 0 Then Exit For
Next iRow
If n < 0 Then Exit For
Next iArea
Dim j As Long
For j = 0 To nValues - 1
Debug.Print ar(j)
Next
End Sub
Looping filtered a list
Option Explicit
Sub Filtered()
Dim rng as Range, ID As Range, a As Range
Dim ar(2) As Long, i As Integer, j As Integer
' apply filter
With Sheet1
.AutoFilterMode = False
.UsedRange.AutoFilter 1, "A123"
Set rng = .UsedRange.Columns(1).SpecialCells(xlCellTypeVisible)
End With
' count
For Each a In rng.Areas
For Each ID In a.Cells
If ID.Row > 1 Then
i = (i + 1) Mod 3
ar(i) = ID.Row
End If
Next
Next
For j = 1 To 3
Debug.Print ar((j + i) Mod 3)
Next
End Sub

Getting the maximum value of a specific column in a 2d array [duplicate]

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

Unique values two columns combobox vba

I need to display two columns A and B listed in a combobox with unique values. So if two rows have the same A but not the same B, it is not a duplicate, both column need to be duplicate. I found a code that list one column (A) with unique values but I don't know how to add the column B.
There's a picture of my data and how I want to display it in my ComboBox.
Here's the code:
Private Sub UserForm_Initialize()
Dim Cell As Range
Dim col As Variant
Dim Descending As Boolean
Dim Entries As Collection
Dim Items As Variant
Dim index As Long
Dim j As Long
Dim RngBeg As Range
Dim RngEnd As Range
Dim row As Long
Dim Sorted As Boolean
Dim temp As Variant
Dim test As Variant
Dim Wks As Worksheet
Set Wks = ThisWorkbook.Worksheets("Sheet1")
Set RngBeg = Wks.Range("A3")
col = RngBeg.Column
Set RngEnd = Wks.Cells(Rows.Count, col).End(xlUp)
Set Entries = New Collection
ReDim Items(0)
For row = RngBeg.row To RngEnd.row
Set Cell = Wks.Cells(row, col)
On Error Resume Next
test = Entries(Cell.Text)
If Err = 5 Then
Entries.Add index, Cell.Text
Items(index) = Cell.Text
index = index + 1
ReDim Preserve Items(index)
End If
On Error GoTo 0
Next row
index = index - 1
Descending = False
ReDim Preserve Items(index)
Do
Sorted = True
For j = 0 To index - 1
If Descending Xor StrComp(Items(j), Items(j + 1), vbTextCompare) = 1 Then
temp = Items(j + 1)
Items(j + 1) = Items(j)
Items(j) = temp
Sorted = False
End If
Next j
index = index - 1
Loop Until Sorted Or index < 1
ComboBox1.List = Items
End Sub
Any clue? Thanks!
Try this code, please. It assumes that unique definition means pairs of values from the two columns, on the same row, to be unique:
Sub UnicTwoValInTwoColumns()
Dim sh As Worksheet, arr As Variant, arrFin As Variant, countD As Long
Dim lastRow As Long, i As Long, j As Long, k As Long, boolDupl As Boolean
Set sh = ActiveSheet 'use here your sheet
'supposing that last row in column A:A is the same in column B:B
'If not, the last row for B:B will be calculated and then the higher will be chosen:
lastRow = sh.Range("A" & Rows.Count).End(xlUp).Row
ReDim arrFin(1 To 2, 1 To lastRow) 'redim the final array for maximum possible number of elements
arr = sh.Range("A3:B" & lastRow).value 'pun in array the range to be analized
k = 1 'initialize the first array element number
For i = 1 To UBound(arr, 1) 'iterate between the array elements
boolDupl = False 'initialize the variable proving that the pair of data already in arrFin
For j = 1 To k 'iterate between the arrFin elements in order to check for duplicates
If arr(i, 1) & arr(i, 2) = arrFin(1, j) & arrFin(2, j) Then
boolDupl = True: Exit For 'if a duplicate is found the loop is exited
End If
Next j
If Not boolDupl Then 'load the arrFin only if a duplicate has not been found
arrFin(1, k) = arr(i, 1): arrFin(2, k) = arr(i, 2)
k = k + 1 'increment the (real) array number of elements
End If
Next
ReDim Preserve arrFin(1 To 2, 1 To k - 1) 'redim array at the real dimension (preserving values)
With Me.ComboBox1
.ColumnCount = 2 'be sure that combo has 2 columns to receive values
.List = WorksheetFunction.Transpose(arrFin) 'fill the combo with the array elements
End With
End Sub
You can paste the code in the form Initialize event, or let the Sub like it is, copy it in the form module and only call it from the event in discussion. I would suggest you to proceed in this las way. If you have (or will have) something else in the event, it would be simpler to identify a problem if it occurs, I think,

Setting cell equal to random value if cell isn't blank in range

At a high level I am trying to set a cell equal to a random cell within a range. The issue I am having is that in this range I want to pull a random Value from, the Value I am taking is the result of an 'if' expression that either sets the cell to a Value or "". So when I chose the random value I only want to choose cells that have an actual value, not the "".
Does anyone know how to get this expected behavior?
The code below shows what I have tried currently, each large block is commented to help with understanding. The block I need help with replaces the values in each column until the next cell is blank then moves to the next column.
upperBound = 1798
lowerBound = 2
Randomize
'This loop section populates the data area with a static value in cell 9,3 then 9,4 etc..
For j = 3 To 15
val = Cells(9, j).Value
For i = 1 To val
Cells(12 + i, j).Value = Cells(9, j)
Next i
Next j
'This loop section uses the cells already populated down each column and replaces that value with the random value from the other range
Dim x As Integer
' Set numrows = number of rows of data.
For j = 3 To 15
NumRows = Range(Cells(13, j), Cells(13, j).End(xlDown)).Rows.Count
' Select cell 13,j.
Cells(13, j).Select
' Establish "For" loop to loop "numrows" number of times.
For x = 1 To NumRows
ActiveCell.Value = Worksheets("2017 Role IDs").Cells(Int((upperBound - lowerBound + 1) * Rnd + lowerBound), 2).Value
' Selects cell down 1 row from active cell.
ActiveCell.Offset(1, 0).Select
Next
Next j
This is the data before the second block runs. I want to replace the values that just match the number in the second row with the random number in the range:
This is what I would like to look like:
But currently it looks like this because the random selector is taking blank values:
Something like this should work for you:
Sub tgr()
Dim wb As Workbook
Dim wsNums As Worksheet
Dim wsDest As Worksheet
Dim aData As Variant
Dim vData As Variant
Dim aNums() As Double
Dim aResults() As Variant
Dim lNumCount As Long
Dim lMaxRows As Long
Dim lRowCount As Long
Dim ixNum As Long
Dim ixResult As Long
Dim ixCol As Long
Set wb = ActiveWorkbook
Set wsNums = wb.Worksheets("2017 Role IDs")
Set wsDest = wb.ActiveSheet
With wsNums.Range("B2", wsNums.Cells(wsNums.Rows.Count, "B").End(xlUp))
If .Row < 2 Then Exit Sub 'No data
lNumCount = WorksheetFunction.Count(.Cells)
If lNumCount = 0 Then Exit Sub 'No numbers
ReDim aNums(1 To lNumCount)
If .Cells.Count = 1 Then
ReDim aData(1 To 1, 1 To 1)
aData(1, 1) = .Value
Else
aData = .Value
End If
'Load populated numeric cells into the aNums array
For Each vData In aData
If Len(vData) > 0 And IsNumeric(vData) Then
ixNum = ixNum + 1
aNums(ixNum) = vData
End If
Next vData
End With
lMaxRows = Application.Max(wsDest.Range("C9:O9"))
If lMaxRows = 0 Then Exit Sub 'Row count not populated in row 9 for each column
ReDim aResults(1 To WorksheetFunction.Max(wsDest.Range("C9:O9")), 1 To 13)
'Populate each column accordingly and pull a random number from aNums
For ixCol = 1 To UBound(aResults, 2)
If IsNumeric(wsDest.Cells(9, ixCol + 2).Value) Then
For ixResult = 1 To CLng(wsDest.Cells(9, ixCol + 2).Value)
Randomize
aResults(ixResult, ixCol) = aNums(Int(Rnd() * lNumCount) + 1)
Next ixResult
End If
Next ixCol
wsDest.Range("C13").Resize(UBound(aResults, 1), UBound(aResults, 2)).Value = aResults
End Sub

How to fix long run times replacing values

I have a spreadsheet with approx. 45,000 rows. Currently I am looping through a column and targeting any cells with a value of 0. Those row numbers get stored in an array. I am then looping through that array, and changing another cell based on the array value. I have 5000 rows with values that need to be reassigned, and it is taking over an hour to run that segment of the code (saving the row numbers to the array only takes a few seconds). Any ideas on how to get the code to run faster? Here is the code:
'Initialize array
Dim myArray() As Variant
Dim x As Long
'Looks for the last row on the "Dates" sheet
Dim lastRow As Long
With ThisWorkbook.Sheets("Dates")
lastRow = .Cells(.Rows.Count, "C").End(xlUp).Row + 1
End With
Dim i As Integer
i = 2
Dim uCounter As Integer
'Loop through all the dates on the "Dates" sheet
While i <= lastRow
'Each date has a counter next to it
uCounter = Worksheets("Dates").Range("B" & i).Value
Dim uDate As String
'Store the date as a string
uDate = Worksheets("Dates").Range("C" & i).Value
Dim startRow As Long, endRow As Long
'Finds the first and last instance of the date on the CERF Data page (45,000 rows)
With Sheets("CERF Data")
startRow = .Range("AN:AN").Find(what:=uDate, after:=.Range("AN1"), LookIn:=xlValues).Row
endRow = .Range("AN:AN").Find(what:=uDate, after:=.Range("AN1"), LookIn:=xlValues, searchdirection:=xlPrevious).Row
End With
Dim j As Long
For j = startRow To endRow
'If the cell in column BB is 0, and the counter is above 0 save row number to array, j being the variable representing row number
If Sheets("CERF Data").Range("BB" & j).Value = 0 And uCounter > 0 Then
'save row number to array
ReDim Preserve myArray(x)
myArray(x) = j
x = x + 1
'decrement counter by 1
uCounter = uCounter - 1
End If
If uCounter = 0 Then Exit For
Next j
i = i + 1
Wend
Dim y As Long
'Loop through the array and assign a value of 2 to all the rows in the array for column AS
For y = LBound(myArray) To UBound(myArray)
Sheets("CERF Data").Range("AS" & myArray(y)).Value = 2
Next y
Thanks!
Without more info this is what I can get you:
Just 1 loop through all the rows, once, checking both if the value on column BB = 0 and the date is within your range of dates:
Option Explicit
Sub Test()
Dim arr, i As Long, DictDates As Scripting.Dictionary
arr = ThisWorkbook.Sheets("CERF Data").UsedRange.Value
Set DictDates = New Scripting.Dictionary 'You need the Microsoft Scripting Runtime Reference for this to work
'Create a dictionary with all the dates you must check
With ThisWorkbook.Sheets("Dates")
LastRow = .Cells(.Rows.Count, 3).End(xlUp).Row
For i = 2 To LastRow
If Not DictDates.Exists(CDate(.Cells(i, 3))) Then DictDates.Add CDate(.Cells(i, 3)), 1
Next i
End With
'Only one loop through the whole array
For i = 1 To UBound(arr)
If arr(i, 54) = 0 And DictDates.Exists(CDate(arr(i, 40))) Then 'check your 2 criterias, date and value = 0
arr(i, 45) = 2 'input the value 2 on the column "AS"
End If
Next i
ThisWorkbook.Sheets("CERF Data").UsedRange.Value = arr
End Sub

Resources