Why is the first random number always the same? - excel

I'm working on a macro that selects a random series of employee id numbers for random testing. The code I have works well except the first number returned is always the same. For example, if my ID numbers are 1-100 and I want 10 random numbers, the first number will always be 1 and then at random after that.
As an extra challenge, is it possible to make it where the same numbers won't be selected until the list has been cycled through?
Here is the code that I'm using.
Sub Macro1()
'
'
'
'
Dim CountCells
Dim RandCount
Dim LastRow
Dim Counter1
Dim Counter2
Worksheets.Add().Name = "Sheet1"
Worksheets("Employee ID#").Select
Range("a2:A431").Select
Selection.Copy
Worksheets("Sheet1").Select
Selection.PasteSpecial
Worksheets("Sheet1").Select
Range("A1").Select
CountCells = WorksheetFunction.Count(Range("A:A")) 'quantity of random numbers to pick from
If CountCells = 0 Then Exit Sub
On Error Resume Next
Application.DisplayAlerts = False
RandCount = Application.InputBox(Prompt:="How many random numbers do you want?", _
Title:="Random Numbers Selection", Type:=1)
On Error GoTo 0
Application.DisplayAlerts = True
RandCount = Int(RandCount)
If Int(RandCount) <= 0 Or RandCount = False Then Exit Sub
If RandCount > CountCells Then
MsgBox "Requested quantity of numbers is greater than quantity of available data"
Exit Sub
End If
LastRow = Cells(Rows.Count, "A").End(xlUp).Row
'clear working area
Range("B:C").ClearContents
'clear destination area
Range("Sheet2!A:A").ClearContents
'create index for sort use
Range("B1") = 1
Range(Cells(1, 2), Cells(LastRow, 2)).DataSeries , Step:=1
'create random numbers for sort
Range("C1") = "=RAND()"
Range("C1").Copy Range(Cells(1, 3), Cells(LastRow, 3))
'randomly sort data
Range(Cells(1, 1), Cells(LastRow, 3)).Sort Key1:=Range("C1"), Order1:=xlAscending, Header:=xlGuess, _
Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
'data has been sorted randomly, cells in column A, rows 1 through the quantity desired will be chosen
Counter1 = 1
Counter2 = 1
Do Until Counter1 > RandCount
If IsNumeric(Cells(Counter2, 1).Value) And Cells(Counter2, 1).Value <> Empty Then
Range("Sheet2!A" & Counter1) = Cells(Counter2, 1).Value
Counter1 = Counter1 + 1
'Selection.ClearContents
End If
Counter2 = Counter2 + 1
Loop
'resort data into original order and clear working area
Range(Cells(1, 1), Cells(LastRow, 3)).Sort Key1:=Range("B1"), Order1:=xlAscending, Header:=xlGuess, _
Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
Range("B:C").ClearContents
Sheets("Sheet2").Select
'Sheets("Sheet2").PrintOut
End Sub
Thanks in advance for any help.

To get a different first number, simply add a line that says Randomize at the start of your function.
You could load the list of employees into an array and then when one is selected, remove the employee from the array so they can't be selected again.
-Edit-
I came up with this bit of code that should work for you. It loads the employee ID#s into an array so you don't have to deal with selecting and rearranging cells which is a slow operation. The code then picks employees from the array of all the employees and adds them to an array of employees to check. It then removes the employee from the array of all the employees so that they cannot be picked again. Once the code has selected the needed number of employees to check, it writes them into the desired sheet.
Sub SelectRandomEntries()
Dim WSEmp As Worksheet
Dim WSCheckedEmps As Worksheet
Dim AllEmps() As Long 'An array to hold the employee numbers
'Assuming Column A is an integer employee #
Dim CheckedEmps() As Long
Dim FirstRow As Long
Dim LastRow As Long
Dim RandCount As Long
Dim RandEmp As Long
Dim i As Long
'Set the worksheets to variables. Make sure they're set to the appropriate sheets in YOUR workbook.
Set WSEmp = ThisWorkbook.Worksheets("Employee ID#") 'Sheet with all employees
Set WSCheckedEmps = ThisWorkbook.Worksheets("Checked Employees") 'Sheet with checked employees
FirstRow = 1
LastRow = WSEmp.Cells(WSEmp.Rows.Count, "A").End(xlUp).Row 'Find the last used row in a ColumnA
Randomize 'Initializes the random number generator.
'Load the employees into an array
ReDim AllEmps(FirstRow To LastRow) 'Make the array large enough to hold the employee numbers
For i = FirstRow To LastRow
AllEmps(i) = WSEmp.Cells(i, 1).Value
Next
'For this example, I sent RandCount to a random number between the first and last entries.
'Rnd() geneates a random number between 0 and 1 so the rest of line converts it to a usable interger.
RandCount = Int((LastRow - FirstRow + 1) * Rnd() + FirstRow)
MsgBox (RandCount & "will be checked")
ReDim CheckedEmps(1 To RandCount)
'Check random employees in the array
For i = 1 To RandCount
RandEmp = Int((LastRow - FirstRow + 1) * Rnd() + FirstRow) 'pick a random employee to check
If IsNumeric(AllEmps(RandEmp)) And AllEmps(RandEmp) <> Empty Then 'If the emp# is valid
CheckedEmps(i) = AllEmps(RandEmp) 'Move the employee to the checked employee list.
AllEmps(RandEmp) = Empty 'Clear the employee from the full list so they can't get picked again
Else
i = i - 1 'If you checked a RandEmp that wasn't suitable, you'll need to check another one.
End If
Next
'Write the employees to the results sheet
For i = 1 To RandCount
WSCheckedEmps.Cells(i, 1) = CheckedEmps(i)
Next i
End Sub
You may need to add checks that are relevant specifically to your data set (I just used a handful of random integers) and you'll want to re-implement a way for people to choose how many employees to check.

Related

VBA - How do I randomly select 10% of rows from a column, ensuring they are different and put a Y in column B?

I am looking to randomly select 10% of tasks worked by different users ('originator' Column P) and place a Y in column B to allow checkers to QC the work. If the 10% is not a whole number then I am required to round up i.e. 0.8 would require 1 row and 1.3 would require 2 rows.
I am new to coding I have been able to add code to filter the rows to show the required date and the 'Originator' in column P then name this range as "userNames". I am not sure how to code to select the random 10%. I have changed the part I am struggling with to bold below.
Sub randomSelection()
Dim dt As Date
dt = "20/08/2021"
Dim lRow As Long
'Format date
Range("J:J").Select
Selection.NumberFormat = "dd/mm/yyyy"
'Select User Grogu
ActiveSheet.Range("$A$1:$W$10000").AutoFilter 10, Criteria1:="=" & dt
ActiveSheet.Range("$A$1:$W$10000").AutoFilter Field:=16, Criteria1:= _
"SW\Grogu"
'Name range "userNames"
With ActiveSheet
lRow = .Cells(Rows.Count, 16).End(xlUp).Row
If lRow < 3 Then Exit Sub
.Cells(1, 16).Offset(1, 0).Resize(lRow - 1).SpecialCells(xlCellTypeVisible).Select
End With
Selection.Name = "userNames"
**'Randomly select 10% of rows from originator and put a Y in column B**
'remove all defined names
On Error Resume Next
ActiveWorkbook.Names("userNames").Delete
'Select User Finn
ActiveSheet.Range("$A$1:$W$10000").AutoFilter 10, Criteria1:="=" & dt
ActiveSheet.Range("$A$1:$W$10000").AutoFilter Field:=16, Criteria1:= _
"SW\Finn"
'Name range "userNames"
With ActiveSheet
lRow = .Cells(Rows.Count, 16).End(xlUp).Row
If lRow < 3 Then Exit Sub
.Cells(1, 16).Offset(1, 0).Resize(lRow - 1).SpecialCells(xlCellTypeVisible).Select
End With
Selection.Name = "userNames"
'remove all defined names
On Error Resume Next
ActiveWorkbook.Names("userNames").Delete
'Formate Date back
Range("J:J").Select
Selection.NumberFormat = "yyyy-mm-dd"
End Sub
I had some free time and wrote up an example program that copies 10% of a defined set of rows, and then pastes it into a different sheet. I have added some comments to help explain what each section is achieving.
Sub Example()
'Define the Start and End of the data range
Const STARTROW As Long = 1
Dim LastRow As Long
LastRow = Sheet1.Cells(Sheet1.Rows.Count, 1).End(xlUp).Row
'Create an Array - Length = Number of Rows in the data
Dim RowArr() As Long
ReDim RowArr(STARTROW To LastRow)
'Fill the Array - Each element is a row #
Dim i As Long
For i = LBound(RowArr) To UBound(RowArr)
RowArr(i) = i
Next i
'Shuffle the Row #'s within the Array
Randomize
Dim tmp As Long, RndNum As Long
For i = LBound(RowArr) To UBound(RowArr)
RndNum = WorksheetFunction.Floor((UBound(RowArr) - LBound(RowArr) + 1) * Rnd, 1) + LBound(RowArr)
tmp = RowArr(i)
RowArr(i) = RowArr(RndNum)
RowArr(RndNum) = tmp
Next i
'Calculate the number of rows to divvy up
Const LIMIT As Double = 0.1 '10%
Dim Size As Long
Size = WorksheetFunction.Ceiling((UBound(RowArr) - LBound(RowArr) + 1) * LIMIT, 1)
If Size > UBound(RowArr) Then Size = UBound(RowArr)
'Collect the chosen rows into a range
Dim TargetRows As Range
For i = LBound(RowArr) To LBound(RowArr) + Size
If TargetRows Is Nothing Then
Set TargetRows = Sheet1.Rows(RowArr(i))
Else
Set TargetRows = Union(TargetRows, Sheet1.Rows(RowArr(i)))
End If
Next i
'Define the Output Location
Dim OutPutRange As Range
Set OutPutRange = Sheet2.Cells(1, 1) 'Top Left Corner
'Copy the randomly chosen rows to the output location
TargetRows.Copy Destination:=OutPutRange.Resize(TargetRows.Rows.Count).EntireRow
End Sub

performance issue - Rearranging columns based on column header

I have an Excel Workbook with hundreds of columns to be rearranged. Having tried different approaches to rearrange those columns I have developed my own solution, because it's faster than what I have found here and elsewhere:
How to rearrange the excel columns by the columns header name
https://code.adonline.id.au/rearrange-columns-excel-vba/
My code:
What I basically do is searching the header row for a certain string and copy that column to a temp/helper sheet, when done I search for the next term and so on until all categories are searched. Afterwards I copy the chunk back to the main sheet in the correct order.
edit: it is of vital importance to keep the formatting of each column, so putting everything in an array does not work, because the formatting information will be gone.
Sub cutColumnsToTempAndMoveBackSorted()
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
Call declareVariables
iCountCompanies = lngLastCol - iColStart + 1
' Timer
Dim StartTime As Double
Dim SecondsElapsed As Double
' Remember time when macro starts
StartTime = Timer
iStartColTemp = 0
wsTempCompanies.UsedRange.Delete
' First copy all columns with "ABC"
For i = iColStart To lngLastCol
If ws.Cells(iRowCategory, i) = "ABC" Then
iStartColTemp = iStartColTemp + 1
ws.Columns(i).Copy
wsTempCompanies.Columns(iStartColTemp).Insert
End If
Next i
' Then copy all columns with "DDD"
For i = iColStart To lngLastCol
If ws.Cells(iRowCategory, i) = "DDD" Then
iStartColTemp = iStartColTemp + 1
ws.Columns(i).Copy
wsTempCompanies.Columns(iStartColTemp).Insert
End If
Next i
' Then copy all columns with "CCC"
For i = iColStart To lngLastCol
If ws.Cells(iRowCategory, i) = "CCC" Or ws.Cells(iRowCategory, i) = "" Then
iStartColTemp = iStartColTemp + 1
ws.Columns(i).Copy
wsTempCompanies.Columns(iStartColTemp).Insert
End If
Next i
' Then copy all columns with "EEE"
For i = iColStart To lngLastCol
If ws.Cells(iRowCategory, i) = "EEE" Then
iStartColTemp = iStartColTemp + 1
ws.Columns(i).Copy
wsTempCompanies.Columns(iStartColTemp).Insert
End If
Next i
Dim iLastColTemp As Integer: iLastColTemp = iStartColTemp
iStartColTemp = 1
ws.Range(Col_Letter(iColStart) & ":" & Col_Letter(lngLastCol)).Delete 'Col_Letter function gives back the column ist characters instead of column ID
' Move back to Main Sheet
wsTempCompanies.Range(Col_Letter(iStartColTemp) & ":" & Col_Letter(iLastColTemp)).Copy
ws.Range(Col_Letter(iColStart + 1) & ":" & Col_Letter(lngLastCol + 1)).Insert
ws.Columns(iColStart).Delete
'Determine how many seconds code took to run
SecondsElapsed = Round(Timer - StartTime, 2)
'Notify user in seconds
Debug.Print "Time: " & SecondsElapsed & " Sekunden."
ende:
Application.ScreenUpdating = True
Call activateApplication ' All kinds of screenupdates, such as enableevents, calculations, ...
End Sub
I am still not happy with my solution as it takes just too much time when there are more than 50 columns. Sometimes I have over 300.
Any suggestion to boost the performance?
The below might be of some help, if it is not too much effort.
Sample Dataset in one sheet (let's call this the Main sheet) with,
(Row 2) Sample Header row (includes the lookup keywords - ABC, DDD, CCC, EEE)
(Row 1) A Temp Row (formulated to show Header Order numbers)
References sheet which lists the lookup keywords in required left-to-right sort order
Back in the Main sheet, we'd like to generate the sequence numbers in Row 1.
As highlighted in the 1st image, it can be done with the below MATCH formula in the cell A1,
=MATCH(TRUE,ISNUMBER(SEARCH(References!$A$2:$A$5,A2)),0)
This is required as an array formula and hence should be executed by hitting Ctrl+Shift+Enter
Now copy the cell A1 across columns (in Row 1) through the last column
Row 1 will now contain sequence numbers 1..n, where n is the numbers of rows found in the References sheet. It may also contain #N/A error value returned by the MATCH formula if no match is found from the 'References' sheet
Now, apply sort (Sort Option: Left to Right) and Sort By Row 1.
The columns should now be sorted as per requirement and with formatting intact.
Result (Sorted)
Please note that a column header not matching any keywords has been moved to the end.
Once you find everything in place, now you can go ahead and delete the (Row 1) temp row in the Main sheet
P.S: While I haven't computed the performance of this approach on a large dataset, I'm sure it will be fairly quick.
Please test the next code, please. Most of the credit must go to #Karthick Ganesan for his idea. The code only puts his idea in VBA:
Sub reorderColumnsByRanking()
Dim sh As Worksheet, arrOrd As Variant, lastCol As Long, i As Long
Dim El As Variant, boolFound As Boolean, isF As Long
Set sh = ActiveSheet 'use here your necessary sheet
lastCol = sh.Cells(1, Columns.Count).End(xlToLeft).Column
arrOrd = Split("ABC|1,DDD|2,CCC|3,EEE|4", ",") 'load criteria and their rank
'insert a helping row____________________
sh.Range("A1").EntireRow.Insert xlAbove
'________________________________________
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
'Rank the columns_______________________________________________________________
For i = 1 To lastCol
For Each El In arrOrd
If IsFound(sh.Cells(2, i), CStr(Split(El, "|")(0))) Then
sh.Cells(1, i).Value = Split(El, "|")(1): boolFound = True: Exit For
End If
Next
If Not boolFound Then sh.Cells(1, i).Value = 16000
boolFound = False
Next i
'_______________________________________________________________________________
'Sort LeftToRight_____________________________________________________________
sh.Sort.SortFields.Add2 key:=sh.Range(sh.Cells(1, 1), sh.Cells(1, lastCol)) _
, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With sh.Sort
.SetRange sh.Range(sh.Cells(1, 1), sh.Cells(1, lastCol)).EntireColumn
.Header = xlYes
.Orientation = xlLeftToRight
.SortMethod = xlPinYin
.Apply
End With
'____________________________________________________________________________
'Delete helping first row____
sh.Rows(1).Delete xlDown
'____________________________
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlCalculationManual
End Sub
Private Function IsFound(rng As Range, strS As String) As Boolean
Dim fC As Range
Set fC = rng.Find(strS)
If Not fC Is Nothing Then
IsFound = True
Else
IsFound = False
End If
End Function
Here's my take on the solution. It's pretty similar to the one in your first link by #BruceWayne except this will go straight to the correct column rather than checking each one.
At the moment the code looks for partial matches - so "ABCDEF" would be found for both "ABC" and "DEF". Change xlPart to xlWhole in the FIND command to have it match against exact headings.
Sub Test()
Dim CorrectOrder() As Variant
Dim OrderItem As Variant
Dim FoundItem As Range
Dim FirstAddress As String
Dim NewOrder As Collection
Dim LastColumn As Range
Dim NewPosition As Long
Dim tmpsht As Worksheet
CorrectOrder = Array("ABC", "DEF", "GHI", "JKL")
With ThisWorkbook.Worksheets("Sheet1")
Set LastColumn = .Cells(2, .Columns.Count).End(xlToLeft) 'Return a reference to last column on row 2.
Set NewOrder = New Collection
With .Range(.Cells(2, 1), LastColumn) 'Refer to the range A2:LastColumn.
'Search for each occurrence of each value and add the column number to a collection in the order found.
For Each OrderItem In CorrectOrder
Set FoundItem = .Find(What:=OrderItem, After:=.Cells(1, 1), LookIn:=xlValues, LookAt:=xlPart)
If Not FoundItem Is Nothing Then
FirstAddress = FoundItem.Address
Do
NewOrder.Add FoundItem.Column
Set FoundItem = .FindNext(FoundItem)
Loop While FoundItem.Address <> FirstAddress
End If
Next OrderItem
End With
End With
'Providing some columns have been found then move them in order to a temporary sheet.
If NewOrder.Count > 1 Then
NewPosition = 2
Set tmpsht = ThisWorkbook.Worksheets.Add
For Each OrderItem In NewOrder
ThisWorkbook.Worksheets("Sheet1").Columns(OrderItem).Cut _
tmpsht.Columns(NewPosition)
NewPosition = NewPosition + 1
Next OrderItem
'Copy the reordered columns back to the original sheet.
tmpsht.Columns(2).Resize(, NewOrder.Count).Cut _
ThisWorkbook.Worksheets("Sheet1").Columns(2)
'Delete the temp sheet.
Application.DisplayAlerts = False
tmpsht.Delete
Application.DisplayAlerts = True
End If
End Sub
You can use Cut which is significantly faster (on PC it is around 20-30 times faster than Copy/Insert approach. Cut also preserves formatting.
Here, is an example how it can be implemented into your code:
For i = iColStart To lngLastCol
If ws.Cells(iRowCategory, i) = "EEE" Then
iStartColTemp = iStartColTemp + 1
ws.Columns(i).Cut wsTempCompanies.Columns(iStartColTemp)
End If
Next i
If for some reason, you are not allowed to cut elements from ws, then it is probably good idea to create temporary copy of that working to work on.

Make every set of eight rows move into columns in Excel

I would like to make every set of eight rows move into columns in Excel for example here is a set with every four rows broken into columns:
From this:
To this:
I've tried this code in VBA which I've seen in a previous question found on https://superuser.com/questions/583595/move-every-7-columns-into-new-row-in-excel
Dim i As Integer, j As Integer, cl As Range
Dim myarray(100, 6) As Integer 'I don't know what your data is. Mine is integer data
'Change 100 to however many rows you have in your original data, divided by seven, round up
'remember arrays start at zero, so 6 really is 7
If MsgBox("Is your entire data selected?", vbYesNo, "Data selected?") <> vbYes Then
MsgBox ("First select all your data")
End If
'Read data into array
For Each cl In Selection.Cells
Debug.Print cl.Value
myarray(i, j) = cl.Value
If j = 6 Then
i = i + 1
j = 0
Else
j = j + 1
End If
Next
'Now paste the array for your data into a new worksheet
Worksheets.Add
Range(Cells(1, 1), Cells(101, 7)) = myarray
End Sub
However, it only seems to work with integers and not data that has both numbers and letters if I am understanding correctly.
I get an error:
Run-time error '13':
Type mismatch
This should do it
Sub movedata()
Dim rowcounter, colcounter, rowcounter2 As Long
colcounter = 3
rowcounter2 = 1
For rowcounter = 1 To Cells(Cells.Rows.Count, 1).End(xlUp).Row
If Cells(rowcounter, 1).Value2 <> "" Then
Cells(rowcounter2, colcounter).Value2 = Cells(rowcounter, 1).Value2
colcounter = colcounter + 1
Else
rowcounter2 = rowcounter2 + 1
colcounter = 3
End If
Next rowcounter
End Sub
So you basically want to transpose the used range of a given sheet? This code may
Option Explicit
Sub transpose()
Dim a As Integer, x As Integer
a = 1 + Cells(1, 1).End(xlToRight).Column
ActiveSheet.UsedRange.Copy
Cells(1, a).Select
Selection.PasteSpecial Paste:=xlPasteAll, transpose:=True
Cells(1, 1).Select
For x = 1 To (a - 1)
Columns(1).Delete
Next x
End Sub
It works as follows:
- find the last used column and define "a" as this columnnumber + 1
- Copy the used range (where your data is)
- transpose into cells(1,a)
- select cells(1,1)
- delete this column (a-1) times
Is this what you are looking for?

Excel Macro to add a character to duplicate values after the value exceeds 15 instances

Currently operating in excel 2010
I am in the process of building a macro to format various reports so that the excel sheets can be input into an auto-load tool. This macro adds a unique number identifier to each case and then breaks cases into multiple lines depending on the amount of services being performed. So initially cases will be numbered in column A as 1,2,3,4,ect. Then the cases are split into multiple rows based on the number of services and the number in column A is used to group the services. So if case one has 3 services, case two has 1 service, and case three has 5 services, column A would look like 1,1,1,2,3,3,3,3,3 descending.
The auto-load tool only builds 15 lines per case. So I need to add code that will search column A and if a duplicate value exceeds 15 instances, add an "a" to the first 15 instances, a "b" to the second 15 instances, a "c" to the third 15 instances, and so on.
example:
In column A desending: if identifier looks like 1,2,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,4
Then macro would update column A to look like this: 1,2,3a,3a,3a,3a,3a,3a,3a,3a,3a,3a,3a,3a,3a,3a,3a,3b,3b,4
Thanks for your time
This is the code I have worked out so far:
Sub Scrub_File()
Dim ws As Worksheet
Set ws = Worksheets("Sheet1")
range("A2").Select
ActiveCell.FormulaR1C1 = "1"
LastRow = range("K" & Rows.Count).End(xlUp).Row
range("A2").AutoFill Destination:=range("A2:A" & LastRow), Type:=xlFillSeries
Dim InxSplit As Long
Dim SplitCell() As String
Dim RowCrnt As Long
With Worksheets("Sheet1")
RowCrnt = 2 ' The first row containing data.
Do While True
If .Cells(RowCrnt, "AI").Value = "End" Then
Exit Do
End If
SplitCell = Split(.Cells(RowCrnt, "AI").Value, ",")
If UBound(SplitCell) > 0 Then
.Cells(RowCrnt, "AI").Value = SplitCell(0)
For InxSplit = 1 To UBound(SplitCell)
RowCrnt = RowCrnt + 1
.Cells(RowCrnt, "AI").Value = SplitCell(InxSplit)
.range(.Cells(RowCrnt, "A"), .Cells(RowCrnt, "AH")).Value = .range(.Cells(RowCrnt - 1, "A"), .Cells(RowCrnt - 1, "AH")).Value
.range(.Cells(RowCrnt, "AL"), .Cells(RowCrnt, "AX")).Value = .range(.Cells(RowCrnt - 1, "AL"), .Cells(RowCrnt - 1, "AX")).Value
Next
End If
RowCrnt = RowCrnt + 1
Loop
End With
End Sub
For an Excel formula, you can use:
=IF(COUNTIF($A:$A,A3)>15, A3&CHAR(96+INT( (COUNTIF($A$3:A3,A3)-1)/15+1)),A3)
where your ID codes are in column A and start at, for example A3.
For a VBA macro, to be run after you have populated your ID column:
Option Explicit
Sub markDups()
Dim WB As Workbook, WS As Worksheet
Dim rID As Range, C As Range, D As Range
Dim lcntID As Long, lposCnt As Long
Set WB = ThisWorkbook
Set WS = WB.Worksheets("sheet1")
With WS
Set rID = .Range(.Cells(3, 1), .Cells(.Rows.Count, 1).End(xlUp)) 'alter as needed
End With
For Each C In rID
Set D = C.Offset(0, 1) 'remove offset to overwrite
lcntID = WorksheetFunction.CountIf(rID, C.Value2)
If lcntID > 15 Then
Set D = C.Offset(0, 1) 'remove offset to overwrite
lposCnt = WorksheetFunction.CountIf(Range(rID(1, 1), C), C)
D = C.Value2 & Chr((lposCnt - 1) \ 15 + 97)
Else
D = C.Value2
End If
Next C
End Sub

Need help to optimize the Excel VBA code that aggregates duplicates

Below is my source table
Name Sales
---------------------------------
Thomas 100
Jay 200
Thomas 100
Mathew 50
Output I need is as below
Name Sales
---------------------------------
Thomas 200
Jay 200
Mathew 50
Basically, I have 2 columns that can have duplicates and I need to aggregate the second column based on first column.
Current code I have is as below. Its working perfectly fine. It takes around 45 seconds to run for 4500 records. I was wondering if there is a more efficient way to do this... as it seems to be a trivial requirement.
'Combine duplicate rows and sum values
Dim Rng As Range
Dim LngRow As Long, i As Long
LngLastRow = lRow 'The last row is calculated somewhere above...
'Initializing the first row
i = 1
'Looping until blank cell is encountered in first column
While Not Cells(i, 1).Value = ""
'Initializing range object
Set Rng = Cells(i, 1)
'Looping from last row to specified first row
For LngRow = LngLastRow To (i + 1) Step -1
'Checking whether value in the cell is equal to specified cell
If Cells(LngRow, 1).Value = Rng.Value Then
Rng.Offset(0, 1).Value = Rng.Offset(0, 1).Value + Cells(LngRow, 2).Value
Rows(LngRow).Delete
End If
Next LngRow
i = i + 1
Wend
Note that this is part of a larger excel app and hence I definitely need the solution to be in Excel VBA.
Here you go:
Option Explicit
Sub Consolidate()
Dim arrData As Variant
Dim i As Long
Dim Sales As New Scripting.Dictionary 'You will need the library Microsoft Scripting Runtime
Application.ScreenUpdating = False 'speed up the code since excel won't show you what is happening
'First of all, working on arrays always speeds up a lot the code because you are working on memory
'instead of working with the sheets
With ThisWorkbook.Sheets("YourSheet") 'change this
i = .Cells(.Rows.Count, 1).End(xlUp).Row 'last row on column A
arrData = .Range("A2", .Cells(i, 2)).Value 'here im assuming your row 1 has headers and we are storing the data into an array
End With
'Then we create a dictionary with the data
For i = 1 To UBound(arrData) 'from row 2 to the last on Q1 (the highest)
If Not Sales.Exists(arrData(i, 1)) Then
Sales.Add arrData(i, 1), arrData(i, 2) 'We add the worker(Key) with his sales(Item)
Else
Sales(arrData(i, 1)) = Sales(arrData(i, 1)) + arrData(i, 2) 'if the worker already exists, sum his sales
End If
Next i
'Now you have all the workers just once
'If you want to delete column A and B and just leave the consolidate data:
With ThisWorkbook.Sheets("YourSheet") 'change this
i = .Cells(.Rows.Count, 1).End(xlUp).Row 'last row on column A
.Range("A2:B" & i).ClearContents
.Cells(2, 1).Resize(Sales.Count) = Application.Transpose(Sales.Keys) 'workers
.Cells(2, 2).Resize(Sales.Count) = Application.Transpose(Sales.Items) 'Their sales
End With
Application.ScreenUpdating = True 'return excel to normal
End Sub
To learn everything about dictionaries (and more) check this
With data in cols A and B like:
Running this short macro:
Sub KopyII()
Dim cell As Range, N As Long
Columns("A:A").Copy Range("C1")
ActiveSheet.Range("C:C").RemoveDuplicates Columns:=1, Header:=xlNo
N = Cells(Rows.Count, "C").End(xlUp).Row
Range("B1").Copy Range("D1")
Range("D2:D" & N).Formula = "=SUMPRODUCT(--(A:A= C2),(B:B))"
End Sub
will produce this in cols C and D:
NOTE:
This relies on Excel's builtin RemoveDuplicates feature.
EDIT#1:
As chris neilsen points out, this function should be a bit quicker to evaluate:
Sub KopyIII()
Dim cell As Range, N As Long, A As Range, C As Range
Set A = Range("A:A")
Set C = Range("C:C")
A.Copy C
C.RemoveDuplicates Columns:=1, Header:=xlNo
N = Cells(Rows.Count, "C").End(xlUp).Row
Range("B1").Copy Range("D1") ' the header
Range("D2:D" & N).Formula = "=SUMIFS(B:B,A:A,C2)"
End Sub

Resources