Search duplicate rows based on 3 columns in all worksheets and update

[PritishS]

Dear Sir/Madam,

Hope you are doing well!

I'm stuck with a new kind a problem.
Details:
I have a worksheet name 'MAT', which is basically a bill of material having columns 'Description', 'Make', 'CatNo' and 'Price'.

Description make CatNo Price
Pencil1 ABC PEN1 100
Pencil2 WER PEN2 123
Ruler1 QAS RUL1 50

Also I have 2 worksheet before 'MAT' named 'Pencil' and 'Ruler', containing database of all pencils and rulers. Those Sheets also have same column like 'Description', 'Make', 'CatNo' and 'Price'. These tables Price I update in regular interval.

Table: Pencil

Description make CatNo Price
Pencil1 ABC PEN1 105
Pencil2 WER PEN2 145
Pencil3 FCD PEN3 121
Pencil4 FCE PEN4 111

Table: Ruler
Description make CatNo Price
Ruler1 QAS RUL1 58
Ruler2 WER RUL2 55
Ruler3 FCD RUL3 32
Ruler4 FCE RUL4 15

Now I need a program, which will Start checking 'MAT' sheet form Row having Pencil1 and check in all two sheets and if found same component 'Pencil1' & 'ABC' & 'PEN1' in any sheet, it will print the price from that sheet to 'MAT' sheet in front of Pencil1 in 'New Price' column.

It's like in 'MAT' sheet

Description make CatNo Price New Price
Pencil1 ABC PEN1 100 105
Pencil2 WER PEN2 123 145
Ruler1 QAS RUL1 50 58

Now here what I have tired and got partial success:

Sub updateprice()

    Dim intRow1 As Integer
    Dim intRow2 As Integer
    Dim strNameSurname1 As String
    Dim strNameSurname2 As String
    
    intRow1 = 7 'The first row the data starts
    intRow2 = intRow1 + 1

    With Worksheets("BOM")
        Do While .Cells(intRow1, 1).Value <> Empty
            Do While .Cells(intRow2, 1).Value <> Empty
                strNameSurname1 = CStr(.Cells(intRow1, 1).Value) & CStr(.Cells(intRow1, 2).Value) & CStr(.Cells(intRow1, 3).Value)
                strNameSurname2 = CStr(.Cells(intRow2, 1).Value) & CStr(.Cells(intRow2, 2).Value) & CStr(.Cells(intRow2, 3).Value)
                If strNameSurname1 = strNameSurname2 Then
                    .Cells(intRow1, 5).Value = .Cells(intRow2, 4).Value '.Cells(intRow1, 4).Value
                   
                End If
                intRow2 = intRow2 + 1
            Loop
            intRow1 = intRow1 + 1
            intRow2 = intRow1 + 1
        Loop
    End With
End Sub

It updates the price if only the same records available in MAT sheet. Like-

Description make CatNo Price New Price
Pencil1 ABC PEN1 100 105
Pencil2 WER PEN2 123 145
Ruler1 QAS RUL1 50 58
Pencil1 ABC PEN1 105
Pencil2 WER PEN2 145
Ruler1 QAS RUL1 58

Basically, this code starts from Row 7 , concatenate 'Pencil1'&'ABC'&'PEN1' and checks for rows down. If found same concatenated record in below row it takes the Price of duplicate row and updates price in col-'New Price' of first row.

But I want this searching to be start from first sheet to all sheets except 'MAT' and if price found then update to col-"New Price' then go for next row of 'Pencil2' and again search into all worksheet and do this operation till the last row of MAT Sheet.

Hope my requirement is clear. I'm using Excel 2007 and Windows7 laptop.

I'll be grateful for any help.

Thanks & Regards,
PritishS

 

[PritishS]

Dear Mick Sir,

Thank you very much for your kind co-operation. I'll test this now and inform you as soon as possible.

Thanks,
PritishS

 

[PritishS]

Dear Mick Sir,

THANK YOU!! THANK YOU!! THANK YOU!! This code is perfect as per my expectation. I'm so grateful to you!
Yesterday I have tested your code and added some of my requirements. I'm posting my full code if somebody needs the same--
All credit goes to Mick Sir

Sub Update_Pricewithbar()
Dim Rng As Range, Dn As Range, n As Long, str As String
Dim sht As Worksheet, Q As Variant, Dic As Object, R As Range

'Show updation is in Progress..Added an Userform to show progress msg
UserForm1.Show vbModeless
UserForm1.Repaint

 Set Dic = CreateObject("scripting.dictionary")
    Dic.CompareMode = vbTextCompare
  With Sheets("MAT")
        Set Rng = .Range(.Range("A2"), .Range("A" & Rows.Count).End(xlUp))
    End With
    For Each Dn In Rng
        With Application
            str = Join(.Transpose(.Transpose(Dn.Resize(, 3))), ",")
         End With
                If Not Dic.exists(str) Then
                    Dic.Add (str), Array(Dn, 3)
                Else
                    Q = Dic(str)
                    Set Q(0) = Union(Q(0), Dn)
                    Dic(str) = Q
             End If
    Next Dn
For Each sht In ActiveWorkbook.Worksheets
    If Not sht.Name = "MAT" Then
        With sht
            Set Rng = .Range(.Range("A4"), .Range("A" & Rows.Count).End(xlUp))
        End With
        For Each Dn In Rng
        With Application
            str = Join(.Transpose(.Transpose(Dn.Resize(, 3))), ",")
            If Dic.exists(str) Then
                Q = Dic(str)
                    Q(1) = Q(1) + 20 'This decides on which column result to show
                   
                    For Each R In Q(0)
                        R.Offset(, Q(1)) = Dn.Offset(, 3)
                    Next R
                Dic(str) = Q
            End If
        End With
       Next Dn
    End If
Next sht

'Unload Notification of Price Updation
UserForm1.Hide

'Inform user that price Updation is done
MsgBox "Price Updation Done as Per New Price!!"

'Code to make blank cells red if Blank Rows are there

Dim LR As Long, i As Long
LR = Range("X" & Rows.Count).End(xlUp).Row
For i = 7 To LR
    With Range("X" & i)
        If .Value = "" And .Offset(, -4) <> "" Then .Interior.Color = RGB(255, 0, 0)
    End With
Next i
MsgBox "Data Not found in database will be in Red Color. This needs to be checked by user manually!!"
End Sub

Hope this will be helpful to someone in need.
One more request, if you kindly re-post your last code with comments (how is works), it would be a great help in case in future modification is required.

Wish you a Very Good Luck in your life.

Thanks & Regards,
PritishS

 

[MickG]

This may help !!!!

[COLOR="Navy"]Sub[/COLOR] MG27May33
'[COLOR="Green"][B]Code with comments[/B][/COLOR]
[COLOR="Navy"]Dim[/COLOR] Rng [COLOR="Navy"]As[/COLOR] Range, Dn [COLOR="Navy"]As[/COLOR] Range, n [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] str [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]String[/COLOR]
[COLOR="Navy"]Dim[/COLOR] sht [COLOR="Navy"]As[/COLOR] Worksheet, Q [COLOR="Navy"]As[/COLOR] Variant, Dic [COLOR="Navy"]As[/COLOR] Object, R [COLOR="Navy"]As[/COLOR] Range
'[COLOR="Green"][B]Dictionary object Created here "Dic".[/B][/COLOR]
'[COLOR="Green"][B]Nb:- A dictionary Object holds "Keys" and "Items" for those Keys[/B][/COLOR]
 [COLOR="Navy"]Set[/COLOR] Dic = CreateObject("scripting.dictionary")
    Dic.CompareMode = vbTextCompare
  '[COLOR="Green"][B]Create range object for data in column "A" of sheet "Mat"[/B][/COLOR]
  [COLOR="Navy"]With[/COLOR] Sheets("Mat")
        [COLOR="Navy"]Set[/COLOR] Rng = .Range(.Range("A2"), .Range("A" & Rows.Count).End(xlUp))
    [COLOR="Navy"]End[/COLOR] With
    
    '[COLOR="Green"][B]Loop through range "Rng" for sheet "mat" only[/B][/COLOR]
    [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
        [COLOR="Navy"]With[/COLOR] Application
            '[COLOR="Green"][B]Create string "str" of columns "A to C" for each row[/B][/COLOR]
            str = Join(.Transpose(.Transpose(Dn.Resize(, 3))), ",")
         [COLOR="Navy"]End[/COLOR] With
              '[COLOR="Green"][B]Place each unique string "str" in Dictionary[/B][/COLOR]
             [COLOR="Navy"]If[/COLOR] Not Dic.exists(str) [COLOR="Navy"]Then[/COLOR]
                
         '[COLOR="Green"][B]"Str" added as "key here!,--, Array added as Dictionary "Item" Here[/B][/COLOR]
                    Dic.Add (str), Array(Dn, 3) '[COLOR="Green"][B] This array contains "Dn" the range[/B][/COLOR]
                    '[COLOR="Green"][B]Object and 3, which represents the last offset column from column "A"[/B][/COLOR]
                  '[COLOR="Green"][B] This allows the column offset for each new value found to be incresed[/B][/COLOR]
                  '[COLOR="Green"][B]or new column (see Q(1) = Q(1)+1) , in code below[/B][/COLOR]
                [COLOR="Navy"]Else[/COLOR]
                  '[COLOR="Green"][B]Q = the items for each unique "Str", i.e. dic(str) = Array(dn,3)  see above:[/B][/COLOR]
                    Q = Dic(str)
                 '[COLOR="Green"][B]The range object in array(dn,3) i.e. Rng is increased in size as repeated[/B][/COLOR]
                 '[COLOR="Green"][B]unique "Str" are found.[/B][/COLOR]
                    [COLOR="Navy"]Set[/COLOR] Q(0) = Union(Q(0), Dn)
                    Dic(str) = Q
             [COLOR="Navy"]End[/COLOR] If
    [COLOR="Navy"]Next[/COLOR] Dn
'[COLOR="Green"][B]Loop though all sheets in worksheet except for sheet "Mat"[/B][/COLOR]
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] sht [COLOR="Navy"]In[/COLOR] ActiveWorkbook.Worksheets
    [COLOR="Navy"]If[/COLOR] Not sht.Name = "Mat" [COLOR="Navy"]Then[/COLOR]
        '[COLOR="Green"][B]Set Range "Rng" for each sheet[/B][/COLOR]
        [COLOR="Navy"]With[/COLOR] sht
            [COLOR="Navy"]Set[/COLOR] Rng = .Range(.Range("A2"), .Range("A" & Rows.Count).End(xlUp))
        [COLOR="Navy"]End[/COLOR] With
        '[COLOR="Green"][B]loop through range for each sheet except "Mat"[/B][/COLOR]
        [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
        [COLOR="Navy"]With[/COLOR] Application
            '[COLOR="Green"][B]Create string i.e columns "A,B,C" for each row in sheet[/B][/COLOR]
            str = Join(.Transpose(.Transpose(Dn.Resize(, 3))), ",")
            '[COLOR="Green"][B]If "Str" already exists in dictionary then !!![/B][/COLOR]
            [COLOR="Navy"]If[/COLOR] Dic.exists(str) [COLOR="Navy"]Then[/COLOR]
               '[COLOR="Green"][B] set the array Array(rng,dn)i.e. "Dic(str) to equal "Q"[/B][/COLOR]
                Q = Dic(str)
                 '[COLOR="Green"][B]increase column count for results by one column[/B][/COLOR]
                    Q(1) = Q(1) + 1
                    '[COLOR="Green"][B]Loop through all ranges "Q(0)" in each unique "Dic(str)"[/B][/COLOR]
                    [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] R [COLOR="Navy"]In[/COLOR] Q(0)
                      '[COLOR="Green"][B]Place from column "C" for each unique "str" found in all sheets, except "mat"[/B][/COLOR]
                      '[COLOR="Green"][B]into new column (column "Q(1)")in sheet "Mat", for each related "Str"[/B][/COLOR]
                        R.Offset(, Q(1)) = Dn.Offset(, 3)
                    [COLOR="Navy"]Next[/COLOR] R
                '[COLOR="Green"][B]Update "Item" in Dictionary[/B][/COLOR]
                Dic(str) = Q
            [COLOR="Navy"]End[/COLOR] If
        [COLOR="Navy"]End[/COLOR] With
       [COLOR="Navy"]Next[/COLOR] Dn
    [COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR] sht
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick

 

[PritishS]

MICK SIR,

YOU ARE SIMPLY GREAT!! THANK YOU FOR YOUR KIND HELP.
Wish you a happy weekend!

Thanks,
PritishS

 

[PritishS]

Dear Mick Sir,

I'm apologizing to bother you again!

I'm getting an error saying- Run time Error: 13 Type mismatch on this line

'Create string i.e columns "A,B,C" for each row in sheet
str = Join(.Transpose(.Transpose(Dn.Resize(, 3))), ",")

I have tried to find the cause and find problem is with my two worksheets where for some row data characters are too
many (Character length: 300 in column A and 10 in Col-B and 15 in Col-C).
I'm getting the error while this code is going through that particular worksheet and reached on that particular
row (or may be one row before that row).
When I decreased the character of that row, codes works fine.

I checked the string length of that row using this code, which shows the string length in a box

dim var1 as string
var1 = "PUT A LONG LONG THING HERE"

MsgBox "String Length =  " & Len(var1) & vbCr & vbCr & var1

Can you please guide me how to solve this problem?

 

[MickG]

Try replacing that line as Shown below:-

'Replace this:-
'str = Join(.Transpose(.Transpose(Dn.Resize(, 3))), ",")
With this:-           
str = Dn.Value & "," & Dn.Offset(, 1).Value & "," & Dn.Offset(, 2).Value

 

[PritishS]

Try replacing that line as Shown below:-

'Replace this:-
'str = Join(.Transpose(.Transpose(Dn.Resize(, 3))), ",")
With this:-           
str = Dn.Value & "," & Dn.Offset(, 1).Value & "," & Dn.Offset(, 2).Value

Mick Sir,

Once again Thanks a lot to you. This resolved the Type Mismatch run time error:13.
I have replaced in 2 places as you guided.
1. When Checking in 'MAT' sheet
2. When Checking all other sheets except 'MAT"

May I know what was the difference between two methods of concatenating strings?

Have a Nice Day!!

PritishS

 

[MickG]

One uses the Join and Transpose Function to joint the first 3 columns, which have a character limit of 255, and the other just concatenates the first 3 columns.!!

 

[PritishS]

Thanks a lot Mick Sir!! I always tried to look around internet and try to resolve problems. I found something like character limits of strings in vba is 255. On the other side seen somewhere that vba string can maximum holds 2^31.
Anyways, I'm truly grateful to you!!

Thanks
PritishS

 

[PritishS]

Dear Mick Sir,
Hope you are in good health and doing well!
It's been almost two years and glad to inform you that your code is doing extremely good.

I am having a small requirement which is going to be extension of the same code.


My question is-

I have a data in "Mat" sheet which is not available in any other sheets.
So after running this code I want to show "Not available" in front of that record so I can understand this record is not available in any sheets.
Thanks in advance.
PritishS

This may help !!!!

[COLOR=Navy]Sub[/COLOR] MG27May33
'[COLOR=Green][B]Code with comments[/B][/COLOR]
[COLOR=Navy]Dim[/COLOR] Rng [COLOR=Navy]As[/COLOR] Range, Dn [COLOR=Navy]As[/COLOR] Range, n [COLOR=Navy]As[/COLOR] [COLOR=Navy]Long,[/COLOR] str [COLOR=Navy]As[/COLOR] [COLOR=Navy]String[/COLOR]
[COLOR=Navy]Dim[/COLOR] sht [COLOR=Navy]As[/COLOR] Worksheet, Q [COLOR=Navy]As[/COLOR] Variant, Dic [COLOR=Navy]As[/COLOR] Object, R [COLOR=Navy]As[/COLOR] Range
'[COLOR=Green][B]Dictionary object Created here "Dic".[/B][/COLOR]
'[COLOR=Green][B]Nb:- A dictionary Object holds "Keys" and "Items" for those Keys[/B][/COLOR]
 [COLOR=Navy]Set[/COLOR] Dic = CreateObject("scripting.dictionary")
    Dic.CompareMode = vbTextCompare
  '[COLOR=Green][B]Create range object for data in column "A" of sheet "Mat"[/B][/COLOR]
  [COLOR=Navy]With[/COLOR] Sheets("Mat")
        [COLOR=Navy]Set[/COLOR] Rng = .Range(.Range("A2"), .Range("A" & Rows.Count).End(xlUp))
    [COLOR=Navy]End[/COLOR] With
    
    '[COLOR=Green][B]Loop through range "Rng" for sheet "mat" only[/B][/COLOR]
    [COLOR=Navy]For[/COLOR] [COLOR=Navy]Each[/COLOR] Dn [COLOR=Navy]In[/COLOR] Rng
        [COLOR=Navy]With[/COLOR] Application
            '[COLOR=Green][B]Create string "str" of columns "A to C" for each row[/B][/COLOR]
            str = Join(.Transpose(.Transpose(Dn.Resize(, 3))), ",")
         [COLOR=Navy]End[/COLOR] With
              '[COLOR=Green][B]Place each unique string "str" in Dictionary[/B][/COLOR]
             [COLOR=Navy]If[/COLOR] Not Dic.exists(str) [COLOR=Navy]Then[/COLOR]
                
         '[COLOR=Green][B]"Str" added as "key here!,--, Array added as Dictionary "Item" Here[/B][/COLOR]
                    Dic.Add (str), Array(Dn, 3) '[COLOR=Green][B] This array contains "Dn" the range[/B][/COLOR]
                    '[COLOR=Green][B]Object and 3, which represents the last offset column from column "A"[/B][/COLOR]
                  '[COLOR=Green][B] This allows the column offset for each new value found to be incresed[/B][/COLOR]
                  '[COLOR=Green][B]or new column (see Q(1) = Q(1)+1) , in code below[/B][/COLOR]
                [COLOR=Navy]Else[/COLOR]
                  '[COLOR=Green][B]Q = the items for each unique "Str", i.e. dic(str) = Array(dn,3)  see above:[/B][/COLOR]
                    Q = Dic(str)
                 '[COLOR=Green][B]The range object in array(dn,3) i.e. Rng is increased in size as repeated[/B][/COLOR]
                 '[COLOR=Green][B]unique "Str" are found.[/B][/COLOR]
                    [COLOR=Navy]Set[/COLOR] Q(0) = Union(Q(0), Dn)
                    Dic(str) = Q
             [COLOR=Navy]End[/COLOR] If
    [COLOR=Navy]Next[/COLOR] Dn
'[COLOR=Green][B]Loop though all sheets in worksheet except for sheet "Mat"[/B][/COLOR]
[COLOR=Navy]For[/COLOR] [COLOR=Navy]Each[/COLOR] sht [COLOR=Navy]In[/COLOR] ActiveWorkbook.Worksheets
    [COLOR=Navy]If[/COLOR] Not sht.Name = "Mat" [COLOR=Navy]Then[/COLOR]
        '[COLOR=Green][B]Set Range "Rng" for each sheet[/B][/COLOR]
        [COLOR=Navy]With[/COLOR] sht
            [COLOR=Navy]Set[/COLOR] Rng = .Range(.Range("A2"), .Range("A" & Rows.Count).End(xlUp))
        [COLOR=Navy]End[/COLOR] With
        '[COLOR=Green][B]loop through range for each sheet except "Mat"[/B][/COLOR]
        [COLOR=Navy]For[/COLOR] [COLOR=Navy]Each[/COLOR] Dn [COLOR=Navy]In[/COLOR] Rng
        [COLOR=Navy]With[/COLOR] Application
            '[COLOR=Green][B]Create string i.e columns "A,B,C" for each row in sheet[/B][/COLOR]
            str = Join(.Transpose(.Transpose(Dn.Resize(, 3))), ",")
            '[COLOR=Green][B]If "Str" already exists in dictionary then !!![/B][/COLOR]
            [COLOR=Navy]If[/COLOR] Dic.exists(str) [COLOR=Navy]Then[/COLOR]
               '[COLOR=Green][B] set the array Array(rng,dn)i.e. "Dic(str) to equal "Q"[/B][/COLOR]
                Q = Dic(str)
                 '[COLOR=Green][B]increase column count for results by one column[/B][/COLOR]
                    Q(1) = Q(1) + 1
                    '[COLOR=Green][B]Loop through all ranges "Q(0)" in each unique "Dic(str)"[/B][/COLOR]
                    [COLOR=Navy]For[/COLOR] [COLOR=Navy]Each[/COLOR] R [COLOR=Navy]In[/COLOR] Q(0)
                      '[COLOR=Green][B]Place from column "C" for each unique "str" found in all sheets, except "mat"[/B][/COLOR]
                      '[COLOR=Green][B]into new column (column "Q(1)")in sheet "Mat", for each related "Str"[/B][/COLOR]
                        R.Offset(, Q(1)) = Dn.Offset(, 3)
                    [COLOR=Navy]Next[/COLOR] R
                '[COLOR=Green][B]Update "Item" in Dictionary[/B][/COLOR]
                Dic(str) = Q
            [COLOR=Navy]End[/COLOR] If
        [COLOR=Navy]End[/COLOR] With
       [COLOR=Navy]Next[/COLOR] Dn
    [COLOR=Navy]End[/COLOR] If
[COLOR=Navy]Next[/COLOR] sht
[COLOR=Navy]End[/COLOR] [COLOR=Navy]Sub[/COLOR]

Regards Mick