youngernest
New Member
- Joined
- May 19, 2023
- Messages
- 3
- Office Version
- 2021
- 2019
- 2016
- Platform
- Windows
I need to compare column A (ref1) and column B (ref2) with the same first 3 characters of a string. For the same 3 characters, then I will copy the entire multiple matching row to new tab. I will then insert one row below each matching and sum column C.
The raw data should look like this
The result will be as below in the new tab
From the new tab, row 2 and 3 have same first 3 character of Cat, then Dog, then Bir.
I tried using below code but got an error.
Do you guys have any idea on how to do this? I only know to do if it has two matching rows. Not able to do for three or more rows like the Dog example.
The raw data should look like this
| Ref1 | Ref2 | Price |
|---|---|---|
| Cat | Green | 2 |
| Yellow | Cathjb | -2 |
| Dog345 | Black | 1 |
| White | Dog | 1 |
| Bird34 | Purple | 4 |
| Dog | Orange | -2 |
| Blue | Bird | 3 |
The result will be as below in the new tab
| Ref1 | Ref2 | Price |
|---|---|---|
| Cat | Green | 2 |
| Yellow | Cathjb | -2 |
| 0 | ||
| Dog345 | Black | 1 |
| White | Dog | 1 |
| Dog | Orange | -2 |
| 0 | ||
| Bird34 | Purple | 4 |
| Blue | Bird | 3 |
| 7 |
I tried using below code but got an error.
VBA Code:
Sub CompareAndCalculateSum()
Dim wsSource As Worksheet
Dim wsDestination As Worksheet
Dim lastRowA As Long
Dim lastRowB As Long
Dim i As Long, j As Long
Dim dictA As Object
Dim dictB As Object
Dim key As String
Dim total As Double
Dim newRow As Long
Dim copyRange As Range
' Set the source and destination worksheets
Set wsSource = ThisWorkbook.Sheets("Sheet1") ' Replace "Sheet1" with the actual name of your source sheet
Set wsDestination = ThisWorkbook.Sheets.Add(After:=wsSource)
wsDestination.Name = "MatchingRows"
' Find the last row in column A and B
lastRowA = wsSource.Cells(wsSource.Rows.Count, "A").End(xlUp).Row
lastRowB = wsSource.Cells(wsSource.Rows.Count, "B").End(xlUp).Row
' Create dictionaries to store the matching groups
Set dictA = CreateObject("Scripting.Dictionary")
Set dictB = CreateObject("Scripting.Dictionary")
' Loop through each row in column A
For i = 1 To lastRowA
' Get the key from the first 3 characters in column A
key = Left(wsSource.Cells(i, "A").Value, 3)
' Check if the key already exists in the dictionary
If Not dictA.exists(key) Then
dictA(key) = New Collection
End If
' Add the row to the matching group
dictA(key).Add i
Next i
' Loop through each row in column B
For j = 1 To lastRowB
' Get the key from the first 3 characters in column B
key = Left(wsSource.Cells(j, "B").Value, 3)
' Check if the key already exists in the dictionary
If Not dictB.exists(key) Then
dictB(key) = New Collection
End If
' Add the row to the matching group
dictB(key).Add j
Next j
' Initialize the newRow variable
newRow = 1
' Loop through each key in dictionary A
For Each key In dictA.keys
' Check if the key exists in dictionary B
If dictB.exists(key) Then
' Calculate the sum in column C for the matching group
total = 0
' Copy the matching rows to the destination sheet and calculate the total
For Each itemA In dictA(key)
For Each itemB In dictB(key)
If copyRange Is Nothing Then
Set copyRange = wsSource.Rows(itemA)
Else
Set copyRange = Union(copyRange, wsSource.Rows(itemA))
End If
total = total + wsSource.Cells(itemA, "C").Value + wsSource.Cells(itemB, "C").Value
Next itemB
Next itemA
' Copy the matching rows to the destination sheet
copyRange.Copy wsDestination.Cells(newRow, 1)
newRow = newRow + copyRange.Rows.Count
' Insert a new row to display the total in column C
wsDestination.Cells(newRow, "C").Value = total
newRow = newRow + 1
' Reset the copyRange variable for the next group
Set copyRange = Nothing
End If
Next key
End SubDo you guys have any idea on how to do this? I only know to do if it has two matching rows. Not able to do for three or more rows like the Dog example.
