I read many post on this forum regarding my problem, but cant find solutions.
I have a table with different number of cells, with duplicate value.
I would like to count duplicates and show in another columns.
Source table where I mark a few cell:
I would like to receive such output
A have a part of code, but whatever I select, it counts the last cell
Dim rng, rngTarget, rngTargetName As Range
Set rngTarget = Range("D7")
Set items = CreateObject("Scripting.Dictionary")
For Each rng In Selection
If Not items.exists(rng.Value) Then
items.Add rng.Value, 1
rngTarget.Value = items(rng.Value)
rngTargetName = rng
Else
items(rng.Value) = items(rng.Value) + 1
rngTarget.Value = items(rng.Value)
rngTargetName = rng
End If
Next
What i missing?
First enter this in a Standard Module:
Public Function unikue(rng As Range)
Dim arr, c As Collection, r As Range
Dim nCall As Long, nColl As Long
Dim i As Long
Set c = New Collection
nCall = Application.Caller.Count
On Error Resume Next
For Each r In rng
If r.Value <> "" Then
c.Add r.Text, CStr(r.Text)
End If
Next r
On Error GoTo 0
nColl = c.Count
If nCall > nColl Then
ReDim arr(1 To nCall, 1 To 1)
For i = 1 To nCall
arr(i, 1) = ""
Next i
Else
ReDim arr(1 To nColl, 1 To 1)
End If
For i = 1 To nColl
arr(i, 1) = c.Item(i)
Next i
unikue = arr
End Function
The above UDF() will return a list of the unique, non-blank, items in a block of cells.
Then in a set of cells in column, say F starting at F5 , array-enter:
=unikue(A1:D3)
In G5 enter:
=COUNTIF($A$1:$D$3,F5)
and copy downward:
With Excel 365, there is a no-VBA solution.
Thanks Gary's for help, but ...
i completed my version of code and now works as expected - i can select few cell and count duplicates.
My working code:
Dim rng As Range
Dim var As Variant
Dim i As Integer
i = 0
Set D = CreateObject("Scripting.Dictionary")
For Each rng In Selection
If rng <> "" Then
If D.exists(rng.Value) Then
D(rng.Value) = D(rng.Value) + 1
Else
D.Add rng.Value, 1
End If
End If
Next
For Each var In D.Keys
Range("C" & (i + 18)) = var
Range("E" & (i + 18)) = D(var)
i = i + 1
Next
Set D = Nothing
Related
I am trying to assign a identifier to the back of the string if there are duplicate values.
I considered a for loop with a counter but it simply gave me a sequence of numbers in each cells.
Is there another way I can approach this matter?
Sub Macro1()
For i = 1 To 10
For N = 1 To 10
If Worksheets("sheet1").Range("A" & i) = Worksheets("sheet1").Range("A" & N) Then
Worksheets("sheet1").Range("A" & i) = Worksheets("sheet1").Range("A" & i) & counter
counter = counter + 1
End If
Next N
Next i
End Sub
There might be other solutions, but this is what I actually came up with.
Don't forget to add this reference to your project:
Tools -> References -> Microsoft Scripting Runtime -> tick checkbox
Sub Macro1()
' Add reference to project:
' Tools -> References -> Microsoft Scripting Runtime -> tick checkbox
Dim dDict As New Scripting.Dictionary
Dim rngInput As Range
Dim sOutputCol As String
Dim lRow As Long, lCount As Long
With ThisWorkbook.Worksheets("SHEET_NAME") ' SHEET_NAME: the name of the sheet where input is
Set rngInput = .Range("A1:A10") ' A1:A10: the range on the sheet where input is
sOutputCol = "C" ' sOutputCol: output column's letter
For lRow = rngInput.Rows(1).Row To rngInput.Rows(rngInput.Rows.Count).Row
If dDict.Exists(rngInput.Cells(lRow, 1).Value2) Then
lCount = dDict(rngInput.Cells(lRow, 1).Value2)
dDict.Remove rngInput.Cells(lRow, 1).Value2
dDict.Add rngInput.Cells(lRow, 1).Value2, lCount + 1
Else
dDict.Add rngInput.Cells(lRow, 1).Value2, 1
End If
.Cells(lRow, sOutputCol).Value2 = rngInput.Cells(lRow, 1).Value2 & "_" & dDict(rngInput.Cells(lRow, 1).Value2)
Next lRow
End With
End Sub
Here's a slightly different Dictionary approach, which gives you an array of the final values.
Sub Tester()
Dim arr, r As Long, dict As Object, rng As Range, v, tmp
Set dict = CreateObject("scripting.dictionary")
Set rng = ActiveSheet.Range("B1:B20")
arr = rng.Value 'get the input values in an array
For r = 1 To UBound(arr, 1) 'loop over all the values
v = arr(r, 1)
If Not dict.exists(v) Then 'new value?
dict.Add v, Array(r, 1) 'store row for the first occurence and start the count
Else
tmp = dict(v) 'not new value: pull array from dict
tmp(1) = tmp(1) + 1 'increment count for this value
If tmp(1) = 2 Then arr(tmp(0), 1) = arr(tmp(0), 1) & "_1" 'second instance? Flag the first occurence also...
arr(r, 1) = arr(r, 1) & "_" & tmp(1) 'flag the n'th instance
dict(v) = tmp 're-store the array
End If
Next r
rng.Offset(0, 2).Value = arr 'output the (updated) array
End Sub
I need to pass the variables max, min, and their respective locations to another sub where it will format each max and min in their respective column. I am trying to create an array that will store the locations and the values but its not working.
I was told to first identify the number of columns used and the number of rows, which is the beginning.
Rows = wsData.UsedRange.Rows.Count
Columns = wsData.UsedRange.Col.Count
j = 1
ReDim Min(j)
With wsData.Range("A3:A19")
For j = 1 To 19 'colum
Min(j) = WorksheetFunction.Min(Range(.Offset(1, j), .Offset(Row, j)))
Max = WorksheetFunction.Max(Range(.Offset(1, j), .Offset(Row, j)))
Min(j) = Min
j = j + 1
ReDim Preserve Min(j) 'saves variables
Next 'next column
End With
The code below uses the ActiveSheet which you need to change to reference the worksheet for your data. Additionally, it assumes that your data starts with Row 1. The code looks at each column in the range and stores the minimum/maximum (it does not account for multiple cells which may share the min or max value) value found in the column as well as the cell's address, in an array and then passes the array to two different subs, one which simply displays the information in a message and one which formats the the background color of the cells. This code does not perform any kind of error handling, but should get you where you want to go.
the line Option Explicit requires that all of the variables be defined using a Dim statement
the line Option Base 1 makes the default starting point for arrays 1 instead of 0
Option Explicit
Option Base 1
Sub GatherData()
Dim iRows As Long
Dim iCols As Long
Dim j As Long
Dim iMin() As Variant
Dim iMax() As Variant
Dim R As Range
iRows = ActiveSheet.UsedRange.Rows.Count
iCols = ActiveSheet.UsedRange.Columns.Count
ReDim iMin(iCols, 2)
ReDim iMax(iCols, 2)
For j = 1 To iCols
Set R = Range(Cells(1, j), Cells(iRows, j)).Find(WorksheetFunction.Min(Range(Cells(1, j), Cells(iRows, j))), LookIn:=xlValues)
iMin(j, 1) = R.Value
iMin(j, 2) = R.Address
Set R = Range(Cells(1, j), Cells(iRows, j)).Find(WorksheetFunction.Max(Range(Cells(1, j), Cells(iRows, j))), LookIn:=xlValues)
iMax(j, 1) = R.Value
iMax(j, 2) = R.Address
Next j
ListMinMax iMax(), True
ListMinMax iMin(), False
FormatMinMax iMax, "green"
FormatMinMax iMin, "yellow"
Set R = Nothing
End Sub
Sub ListMinMax(ByRef Arr() As Variant, ByVal MinMax As Boolean)
Dim strOutput As String
Dim i As Long
If MinMax = True Then
strOutput = "Maximums:" & vbCrLf & vbCrLf
Else
strOutput = "Minimums:" & vbCrLf & vbCrLf
End If
For i = 1 To UBound(Arr, 1)
strOutput = strOutput & "Cell: " & Arr(i, 2) & " = " & Arr(i, 1) & vbCrLf
Next i
MsgBox strOutput, vbOKOnly
End Sub
Sub FormatMinMax(ByRef Arr() As Variant, ByVal BGColor As String)
Dim i As Long
Select Case UCase(BGColor)
Case "GREEN"
For i = 1 To UBound(Arr, 1)
ActiveSheet.Range(Arr(i, 2)).Interior.Color = vbGreen
Next i
Case "YELLOW"
For i = 1 To UBound(Arr, 1)
ActiveSheet.Range(Arr(i, 2)).Interior.Color = vbYellow
Next i
Case Else
MsgBox "Invalid Option", vbCritical
End Select
End Sub
======================================================================
The code below does away with the need for the arrays and formats the color of the min/max values as it finds them
Sub GatherData2()
Dim iRows As Long
Dim iCols As Long
Dim j As Long
Dim R As Range
iRows = ActiveSheet.UsedRange.Rows.Count
iCols = ActiveSheet.UsedRange.Columns.Count
For j = 1 To iCols
Set R = Range(Cells(1, j), Cells(iRows, j)).Find(WorksheetFunction.Min(Range(Cells(1, j), Cells(iRows, j))), LookIn:=xlValues)
R.Interior.Color = vbYellow
Set R = Range(Cells(1, j), Cells(iRows, j)).Find(WorksheetFunction.Max(Range(Cells(1, j), Cells(iRows, j))), LookIn:=xlValues)
R.Interior.Color = vbGreen
Next j
Set R = Nothing
End Sub
I am trying to copy data from one workbook to another based on the values contained in cells in the source workbook that matches the same values in the target workbook. For example, I have a table (Table1) that has four columns say, A1:D5. One of these columns (column A) contains account numbers that match similar account numbers located on another workbook (also in column A). I am trying to find a code that looks through the table (Table1) in the source workbook via the account number column, and if the account number matches the account number in the target workbook, copy and paste the cells on that row in specific locations to the target workbook. Is this possible?
I hope that makes sense. I have looked all over on how to structure such a code, and I was not able to find anything to start the process for this logic.
Any help will be very appreciative.
Thank you
Even if your question is about doing this in VBA, I'm just going to mention that what you are trying to do seems like it could also be done with Power Query.
That being said, if you were to use VBA for this, you would have to use the Match function to find where your rows match and then copy the data from the source to the destination table.
I've adapted the code I provided to this question to better serve your specific needs. One of the things I've done is to add an optional argument called DoOverwrite and set it to false. This will make sure that the information from one row won't be overwritten by another row later down the road.
Sub TableJoinTest()
'Those table columns will have to match for the 2 lines to be a match
Dim MandatoryHeaders() As Variant
MandatoryHeaders = Array("Account Number")
Dim SourceTableAnchor As Range
Set SourceTableAnchor = Workbooks("SourceWorkbook.xlsx").Sheets("Sheet1").Range("A1")
Dim TargetTableAnchor As Range
Set TargetTableAnchor = Workbooks("TargetWorkbook.xlsx").Sheets("Sheet1").Range("A1")
TableJoin _
SourceTableAnchor:=SourceTableAnchor, _
TargetTableAnchor:=TargetTableAnchor, _
MandatoryHeaders:=MandatoryHeaders, _
AddIfMissing:=False, _
IsLogging:=False, _
DoOverwrite:=False
End Sub
Sub TableJoin( _
SourceTableAnchor As Range, _
TargetTableAnchor As Range, _
MandatoryHeaders As Variant, _
Optional OtherHeaders As Variant, _
Optional AddIfMissing As Boolean = False, _
Optional IsLogging As Boolean = False, _
Optional DoOverwrite As Boolean = True)
'''''''''''''''''''''''''''''''''''''''
'Definitions
'''''''''''''''''''''''''''''''''''''''
Dim srng As Range, trng As Range
Set srng = SourceTableAnchor.CurrentRegion
Set trng = TargetTableAnchor.CurrentRegion
Dim sHeaders As Range, tHeaders As Range
Set sHeaders = srng.Rows(1)
Set tHeaders = trng.Rows(1)
'Store in Arrays
Dim sArray() As Variant 'prefix s is for Source
sArray = ExcludeRows(srng, 1).Value2
Dim tArray() As Variant 'prefix t is for Target
tArray = ExcludeRows(trng, 1).Value2
Dim sArrayHeader As Variant
sArrayHeader = sHeaders.Value2
Dim tArrayHeader As Variant
tArrayHeader = tHeaders.Value2
'Find Column correspondance
Dim sMandatoryHeadersColumn As Variant
ReDim sMandatoryHeadersColumn(LBound(MandatoryHeaders) To UBound(MandatoryHeaders))
Dim tMandatoryHeadersColumn As Variant
ReDim tMandatoryHeadersColumn(LBound(MandatoryHeaders) To UBound(MandatoryHeaders))
Dim k As Long
For k = LBound(MandatoryHeaders) To UBound(MandatoryHeaders)
sMandatoryHeadersColumn(k) = Application.Match(MandatoryHeaders(k), sArrayHeader, 0)
tMandatoryHeadersColumn(k) = Application.Match(MandatoryHeaders(k), tArrayHeader, 0)
Next k
Dim sOtherHeadersColumn As Variant
ReDim sOtherHeadersColumn(LBound(OtherHeaders) To UBound(OtherHeaders))
Dim tOtherHeadersColumn As Variant
ReDim tOtherHeadersColumn(LBound(OtherHeaders) To UBound(OtherHeaders))
For k = LBound(OtherHeaders) To UBound(OtherHeaders)
sOtherHeadersColumn(k) = Application.Match(OtherHeaders(k), sArrayHeader, 0)
tOtherHeadersColumn(k) = Application.Match(OtherHeaders(k), tArrayHeader, 0)
Next k
'Merge mandatory headers into one column (aka the helper column method)
Dim i As Long, j As Long
Dim sHelperColumn() As Variant
ReDim sHelperColumn(LBound(sArray, 1) To UBound(sArray, 1), 1 To 1)
For i = LBound(sArray, 1) To UBound(sArray, 1)
For j = LBound(MandatoryHeaders) To UBound(MandatoryHeaders)
sHelperColumn(i, 1) = sHelperColumn(i, 1) & sArray(i, sMandatoryHeadersColumn(j))
Next j
Next i
Dim tHelperColumn() As Variant
ReDim tHelperColumn(LBound(tArray, 1) To UBound(tArray, 1), 1 To 1)
For i = LBound(tArray, 1) To UBound(tArray, 1)
For j = LBound(MandatoryHeaders) To UBound(MandatoryHeaders)
tHelperColumn(i, 1) = tHelperColumn(i, 1) & tArray(i, tMandatoryHeadersColumn(j))
Next j
Next i
'Find all matches
Dim MatchList() As Variant
Dim LoggingColumn() As String
ReDim LoggingColumn(LBound(tArray, 1) To UBound(tArray, 1), 1 To 1)
For i = LBound(sArray, 1) To UBound(sArray, 1)
ReDim MatchList(LBound(tArray, 1) To UBound(tArray, 1))
For j = LBound(tArray, 1) To UBound(tArray, 1)
If sHelperColumn(i, 1) = tHelperColumn(j, 1) Then
MatchList(j) = 1
End If
Next j
'Get the row number for the match
Dim MatchRow As Long
Select Case Application.Sum(MatchList)
Case Is > 1
'Need to do more matching
Dim MatchingScoresList() As Long
ReDim MatchingScoresList(1 To UBound(tArray, 1))
Dim m As Long
For k = LBound(OtherHeaders) To UBound(OtherHeaders)
For m = LBound(tArray, 1) To UBound(tArray, 1)
If tArray(m, sOtherHeadersColumn(k)) = sArray(i, sOtherHeadersColumn(k)) Then
MatchingScoresList(m) = MatchingScoresList(m) + 2 ^ (UBound(OtherHeaders) - k)
End If
Next m
Next k
'Get the max score position
Dim MyMax As Long
MyMax = Application.Max(MatchingScoresList)
If Application.Count(Application.Match(MatchingScoresList(), Array(MyMax), 0)) > 1 Then
MsgBox "Error: can't determine how to match row " & i & " in source table"
Exit Sub
Else
MatchRow = Application.Match(MyMax, MatchingScoresList, 0)
End If
Case Is = 1
MatchRow = Application.Match(1, MatchList, 0)
Case Else
Dim nArray() As Variant, Counter As Long
If AddIfMissing Then
MatchRow = 0
Counter = Counter + 1
ReDim nArray(1 To Counter, 1 To UBound(tArray, 2))
For k = LBound(MandatoryHeaders) To UBound(MandatoryHeaders)
nArray(Counter, tMandatoryHeadersColumn(k)) = sArray(i, sMandatoryHeadersColumn(k))
Next k
For k = LBound(OtherHeaders) To UBound(OtherHeaders)
nArray(Counter, tOtherHeadersColumn(k)) = sArray(i, sOtherHeadersColumn(k))
Next k
Else
MsgBox "Error: Couldn't find a match for data row #" & i
Exit Sub
End If
End Select
'Logging and assigning values
If MatchRow > 0 Then
For k = LBound(OtherHeaders) To UBound(OtherHeaders)
If tArray(MatchRow, tOtherHeadersColumn(k)) <> sArray(i, sOtherHeadersColumn(k)) Then
'Logging
If IsLogging And DoOverwrite Then LoggingColumn(MatchRow, 1) = LoggingColumn(MatchRow, 1) & _
IIf(LoggingColumn(MatchRow, 1) <> "", ", ", "") & _
tHeaders.Cells(1, tOtherHeadersColumn(k)) & " : " & _
tArray(MatchRow, tOtherHeadersColumn(k)) & _
" -> " & sArray(i, sOtherHeadersColumn(k))
'Assign new value
If DoOverwrite Or tArray(MatchRow, tOtherHeadersColumn(k)) = VbNullString Then
tArray(MatchRow, tOtherHeadersColumn(k)) = sArray(i, sOtherHeadersColumn(k))
End If
End If
Next k
End If
Next i
'Write arrays to sheet
ExcludeRows(trng, 1).Value2 = tArray
With trng.Parent
If IsArrayInitialised(nArray) And AddIfMissing Then
.Cells(trng.Cells(1, 1).Row + trng.Rows.Count, trng.Cells(1, 1).Column).Resize(UBound(nArray, 1), UBound(nArray, 2)).Value2 = nArray
End If
If IsLogging Then
.Cells(trng.Cells(1, 1).Row, trng.Cells(1, 1).Column + trng.Columns.Count) = "Changes"
.Cells(trng.Cells(2, 1).Row, trng.Cells(1, 1).Column + trng.Columns.Count).Resize(UBound(LoggingColumn, 1), 1).Value2 = LoggingColumn
End If
End With
End Sub
And also add these functions inside your VBA project to as they are used in the procedure above.
Function IsArrayInitialised(ByRef A() As Variant) As Boolean
On Error Resume Next
IsArrayInitialised = IsNumeric(UBound(A))
On Error GoTo 0
End Function
Function ExcludeRows(MyRng As Range, StartRow As Long, Optional EndRow As Long = -1) As Range
'PURPOSE: Exclude one or more consecutives rows from an existing range
Dim Afterpart As Range, BeforePart As Range
If StartRow < 1 Or EndRow > MyRng.Rows.Count Then Set ExcludeRows = Nothing
If StartRow = 1 And EndRow = MyRng.Rows.Count Then Set ExcludeRows = Nothing
If EndRow = -1 Then EndRow = StartRow
If EndRow < MyRng.Rows.Count Then
With MyRng.Parent
Set Afterpart = .Range(MyRng.Cells(EndRow + 1, 1), MyRng.Cells(MyRng.Rows.Count, MyRng.Columns.Count))
End With
End If
If StartRow > 1 Then
With MyRng.Parent
Set BeforePart = .Range(MyRng.Cells(1, MyRng.Cells(1, 1).Column), MyRng.Cells(StartRow - 1, MyRng.Columns.Count))
End With
End If
Set ExcludeRows = Union2(True, BeforePart, Afterpart)
End Function
Public Function Union2(IgnoreEmptyRange As Boolean, ParamArray RangeArray() As Variant) As Range
'PURPOSE: Samae as Application.Union but allows some range object to be Empty
Dim V As Variant
Dim Rng As Range
For Each V In RangeArray
Do
If VarType(V) = vbEmpty Then Exit Do
Set Rng = V
If Not Union2 Is Nothing Then
Set Union2 = Union(Union2, Rng)
ElseIf Not Rng Is Nothing Then
Set Union2 = Rng
End If
Loop While False
Next
End Function
I am trying to convert the data based on the max repeated values.
I have truck numbers in col A and "Truck types" in column in B col.
For each unique truck number, the truck type should be same.(This is the expected result)
This can be achieved, by counting the maximum no. of truck types for the unique "truck no", and that cell to be updated with the Max. repeated "Truck type".
If there is equal no. of "Truck types" are available, It should be updated with the first available truck type.
Like this, there are thousands of rows to be updated. This can be
better understand by seeing the attached image.
I have attached the image & expected result is in the column C.
I have googled a lot, but I was unable to find the relevant solution.
Please help.
You do not say anything...
Please, test the next code. It works with assumption that the columns are sorted as we can see in the picture. It is very fast, since the result is put in an array and dropped on the sheet at once:
Sub findMaxCountVehType_Array()
Dim sh As Worksheet, lastRow As Long, rngVeh As Range, rngTemp As Range, arrFin As Variant
Dim i As Long, j As Long, w As Long, count As Long, maxCount As Long, ar As Long, maxStr As String
Set sh = ActiveSheet 'use here your sheet
lastRow = sh.Range("A" & Rows.count).End(xlUp).row
Set rngVeh = sh.Range("A2:C" & lastRow)
ReDim arrFin(1 To lastRow, 1 To 1)
arrFin(1, 1) = "Result": ar = 1
For i = 2 To lastRow
If sh.Range("A" & i).Value = sh.Range("A" & i + 1).Value Then
For j = i To j + 1000 'create a range of type cells for the same vehicle no
If sh.Range("A" & j).Value = sh.Range("A" & i).Value Then
If rngTemp Is Nothing Then
Set rngTemp = sh.Range("B" & j)
Else
Set rngTemp = Union(rngTemp, sh.Range("B" & j))
End If
Else
Exit For
End If
Next j
If rngTemp Is Nothing Then
ar = ar + 1: arrFin(ar, 1) = sh.Range("B" & i)
Else
For w = 1 To rngTemp.Cells.count 'determine the max occurrences string
count = WorksheetFunction.CountIf(rngTemp, rngTemp.Cells(w, 1).Value)
If count > maxCount Then maxCount = count: maxStr = rngTemp.Cells(w, 1).Value
Next
For w = 1 To rngTemp.Cells.count
ar = ar + 1: arrFin(ar, 1) = maxStr 'fill the max count in the array
Next
End If
Set rngTemp = Nothing: maxCount = 0: count = 0 'reinitialize variables
i = i + w - 2 'move the iteration to the following vehicle
Else
ar = ar + 1: arrFin(ar, 1) = sh.Range("B" & i)
End If
Next i
'drop the result array at once
sh.Range("C1").Resize(UBound(arrFin, 1), UBound(arrFin, 2)).Value = arrFin
End Sub
Here is a VBA routine that uses:
A class object which has
key:= Vehicle number
item:= dictionary of associated vehicle types
key:= vehicle type
item:= count of the vehicle types
After collecting the information, we merely need to cycle through the dictionary and extract, for any given vehicle ID, the vehicle type that has the largest count.
This routine, since it works entirely with VBA arrays, should run pretty fast, even with large amounts of data.
Also, with this method, no sorting is required.
ASSUMES the data starts in cell A1 (could be changed if necessary)
ASSUMES results are as you show with Desired Result in column C
Be sure to set a reference (Tools/References) to Microsoft Scripting Runtime
Class Module (rename this module cVehicle)
Option Explicit
Private pVehicleType As String
Private pVehicleTypes As Dictionary
Public Property Get VehicleType() As String
VehicleType = pVehicleType
End Property
Public Property Let VehicleType(Value As String)
pVehicleType = Value
End Property
Public Property Get VehicleTypes() As Dictionary
Set VehicleTypes = pVehicleTypes
End Property
Public Function addVehicleTypesItem(Value)
If pVehicleTypes.Exists(Value) Then
pVehicleTypes(Value) = pVehicleTypes(Value) + 1
Else
pVehicleTypes.Add Key:=Value, Item:=1
End If
End Function
Private Sub Class_Initialize()
Set pVehicleTypes = New Dictionary
pVehicleTypes.CompareMode = TextCompare
End Sub
Regular Module
'Set Reference to Microsoft Scripting Runtime
Option Explicit
Sub vehicle()
Dim dV As Dictionary, cV As cVehicle
Dim wsData As Worksheet, vData As Variant, rRes As Range
Dim V As Variant, I As Long, sKey As String, cKey As String, Cnt As Long
'set data worksheet
'read data into vba array
Set wsData = Worksheets("Sheet3")
With wsData
'add extra column for the "desired results"
vData = .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp)).Resize(columnsize:=3)
Set rRes = .Cells(1, 1)
End With
'loop through the data and count the types
'no sorting necessary
Set dV = New Dictionary
For I = 2 To UBound(vData, 1)
Set cV = New cVehicle
With cV
sKey = vData(I, 1)
.VehicleType = vData(I, 2)
If Not dV.Exists(sKey) Then
.addVehicleTypesItem .VehicleType
dV.Add sKey, cV
Else
dV(sKey).addVehicleTypesItem .VehicleType
End If
End With
Next I
'Output the data
I = 1
'Header
vData(I, 3) = "Desired Result"
'Data
For I = 2 To UBound(vData, 1)
sKey = vData(I, 1)
With dV(sKey)
'which type has the highest count
Cnt = 0
For Each V In .VehicleTypes.Keys
If .VehicleTypes(V) > Cnt Then
Cnt = .VehicleTypes(V)
cKey = V
End If
Next V
vData(I, 3) = cKey
End With
Next I
'write the results
Set rRes = rRes.Resize(UBound(vData, 1), UBound(vData, 2))
rRes = vData
End Sub
On Sheet1, I have a set of data with column A showing names and column B marital status.
I would like to output the name based on the marital status to Sheet2 where I have a predetermined dashboard (A1 could be start of table)
The data set will be dynamic and grow each time the vba is run
what I'd like the output data to be
Would you kindly assist in the vba code for this output?
Update, here is the code I have...which works but would like input on code efficiency
Dim K As Long, r As Range, v As Variant
K = 1
Dim w1 As Worksheet, w2 As Worksheet
Set w1 = Sheets("Sheet1")
Set w2 = Sheets("Sheet2")
w1.Activate
For Each r In Intersect(Range("B:B"), ActiveSheet.UsedRange)
v = r.Value
If InStr(v, "Divorced") > 0 Then
r.Offset(, -1).Copy w2.Cells(K + 3, 2)
K = K + 1
End If
Next r
K = 1
For Each r In Intersect(Range("B:B"), ActiveSheet.UsedRange)
v = r.Value
If InStr(v, "Married") > 0 Then
r.Offset(, -1).Copy w2.Cells(K + 3, 3)
K = K + 1
End If
Next r
K = 1
For Each r In Intersect(Range("B:B"), ActiveSheet.UsedRange)
v = r.Value
If InStr(v, "Single") > 0 Then
r.Offset(, -1).Copy w2.Cells(K + 3, 4)
K = K + 1
End If
Next r
K = 1
For Each r In Intersect(Range("B:B"), ActiveSheet.UsedRange)
v = r.Value
If InStr(v, "Widowed") > 0 Then
r.Offset(, -1).Copy w2.Cells(K + 3, 5)
K = K + 1
End If
Next r
If you're looking for the best way to code it, here's how I would do it. This ran about a million rows of data in 11 seconds. Code commented for clarity. Adjust the variable values to match your actual data where necessary.
EDIT: Added variable to allow for output column on wsDest to begin at defined column instead of assuming column A. Set it to B to match OP's code.
Sub tgr()
Const lDataHeaderRow As Long = 1 'The header row of your 2-column original data worksheet
Const lDestHeaderRow As Long = 1 'The header row of your multi-column destination/output worksheet
Const sDestStartCol As String = "B" 'The column letter where the output results begin
Dim wb As Workbook
Dim wsData As Worksheet
Dim wsDest As Worksheet
Dim rDestHeaders As Range
Dim hResults As Object
Dim aData As Variant
Dim aResults() As Variant
Dim vTemp As Variant
Dim i As Long
Set wb = ActiveWorkbook
Set wsData = wb.Worksheets("Sheet1")
Set wsDest = wb.Worksheets("Sheet2")
Set rDestHeaders = wsDest.Range(wsDest.Cells(lDestHeaderRow, sDestStartCol), wsDest.Cells(lDestHeaderRow, wsDest.Columns.Count).End(xlToLeft))
Set hResults = CreateObject("Scripting.Dictionary") 'Use a dictionary to keep track of marital statuses and associated names
'Define your data range here and load it into a variant array for processing
With wsData.Range("A" & lDataHeaderRow + 1, wsData.Cells(wsData.Rows.Count, "B").End(xlUp))
If .Row <= lDataHeaderRow Then Exit Sub 'No data
ReDim aResults(1 To Evaluate("MAX(COUNTIF('" & wsData.Name & "'!B:B,'" & wsDest.Name & "'!" & rDestHeaders.Address & "))"), 1 To rDestHeaders.Cells.Count)
aData = .Value
End With
'Define which column is for which header, the "|0" is the starting count found for that marital status
For i = 1 To rDestHeaders.Cells.Count
hResults(LCase(Trim(rDestHeaders.Cells(, i).Value))) = i & "|" & 0
Next i
'Loop through the variant array, looking at column 2 for the status
For i = LBound(aData, 1) To UBound(aData, 1)
'Verify column 1 and 2 and aren't blank
If Len(Trim(aData(i, 1))) > 0 And Len(Trim(aData(i, 2))) > 0 Then
'Verify current marital status (column 2) is listed in the destination headers
If hResults.Exists(LCase(Trim(aData(i, 2)))) Then
vTemp = Split(hResults(LCase(Trim(aData(i, 2)))), "|")
vTemp(1) = vTemp(1) + 1
aResults(vTemp(1), vTemp(0)) = aData(i, 1)
hResults(LCase(Trim(aData(i, 2)))) = Join(vTemp, "|")
End If
End If
Next i
'Clear previous results
Intersect(wsDest.Cells(lDestHeaderRow, sDestStartCol).CurrentRegion, rDestHeaders.EntireColumn).Offset(1).ClearContents
'Output results
wsDest.Cells(lDestHeaderRow + 1, sDestStartCol).Resize(UBound(aResults, 1), UBound(aResults, 2)).Value = aResults
End Sub