Macro required

D

Damo10

Active Member
Joined
Dec 13, 2010
Messages
460
Hi,

I have a workbook that I have created that imports data from 4 other workbooks and lists the data on the "Data" sheet, what I would like to have is a macro that will look through all the rows on this sheet and if it finds matches of data in 4 columns then have a message box pop up asking if the match would like to be comnined, if yes then the values for the matching rows in columns G & K be added together and entered into the first matching row and then the other matching rows deleted, the macro would then need to check if there are any other matches as there may be more than 1

See example of before and after

Excel Workbook
BCDEFGHIJK
1MachineIndexStartCustomerFillerAmmountCode%No Bags
214100:00Fredfudge100fu11010
314200:50Billcream200cr11020
414502:10Ellencream250cr11025
534800:00Bobfruit50fr12010
6341506:00Davemix300mx12060
7341807:00Edchocolate200ch1510
8342008:00Willchocolate500ch1525
Sheet1
Excel Workbook
BCDEFGHIJK
1MachineIndexStartCustomerFillerAmmountCode%No Bags
214100:00Fredfudge100fu11010
314200:50Billcream450cr11045
434800:00Bobfruit50fr12010
5341506:00Davemix300mx12060
6341807:00Edchocolate700ch1535
Excel 2010 Sheet2
Excel 2010
 

Excel Facts

Save Often
If you start asking yourself if now is a good time to save your Excel workbook, the answer is Yes
Sort by date Sort by votes
Try this:-
Code: 
[COLOR="Navy"]Sub[/COLOR] MG04Jul44
[COLOR="Navy"]Dim[/COLOR] Rng     [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] Dn      [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] nRng    [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] Tri     [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]String[/COLOR]
[COLOR="Navy"]Dim[/COLOR] Q       [COLOR="Navy"]As[/COLOR] Variant
[COLOR="Navy"]Dim[/COLOR] K
[COLOR="Navy"]Dim[/COLOR] nnRng   [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Set[/COLOR] Rng = Range(Range("B2"), Range("B" & rows.count).End(xlUp))
[COLOR="Navy"]With[/COLOR] CreateObject("scripting.dictionary")
.CompareMode = vbTextCompare
    [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
        Tri = Dn & Dn(, 8) & Dn(, 9)
        [COLOR="Navy"]If[/COLOR] Not .Exists(Tri) [COLOR="Navy"]Then[/COLOR]
            .Add Tri, Dn
        [COLOR="Navy"]Else[/COLOR]
            [COLOR="Navy"]Set[/COLOR] .Item(Tri) = Union(.Item(Tri), Dn)
        [COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR]
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] K [COLOR="Navy"]In[/COLOR] .keys
    [COLOR="Navy"]If[/COLOR] .Item(K).count > 1 [COLOR="Navy"]Then[/COLOR]
    [COLOR="Navy"]If[/COLOR] MsgBox("Amalgamate !!! ", vbOKCancel + vbQuestion, "Accept/Reject") = vbOK [COLOR="Navy"]Then[/COLOR]
        .Item(K).Offset(, 5).Resize(1) = Application.sum(.Item(K).Offset(, 5))
        .Item(K).Offset(, 9).Resize(1) = Application.sum(.Item(K).Offset(, 9))
            [COLOR="Navy"]If[/COLOR] nnRng [COLOR="Navy"]Is[/COLOR] Nothing [COLOR="Navy"]Then[/COLOR]
                [COLOR="Navy"]Set[/COLOR] nnRng = .Item(K).Offset(1).Resize(.Item(K).count - 1)
            [COLOR="Navy"]Else[/COLOR]
                 [COLOR="Navy"]Set[/COLOR] nnRng = Union(nnRng, .Item(K).Offset(1).Resize(.Item(K).count - 1))
            [COLOR="Navy"]End[/COLOR] If
    [COLOR="Navy"]End[/COLOR] If
    [COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR] K
[COLOR="Navy"]If[/COLOR] Not nnRng [COLOR="Navy"]Is[/COLOR] Nothing [COLOR="Navy"]Then[/COLOR]
    nnRng.EntireRow.Delete
[COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]End[/COLOR] With
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]
Regards Mick
 
Upvote 0
Hi Mick,

Thanks for your reply.

I have tried it and the message box comes up but when i press the ok button the message box reappers and eventually an error message comes up on line

Code: 
 .Item(K).Offset(, 5).Resize(1) = Application.Sum(.Item(K).Offset(, 5))

Regards
 
Upvote 0
Try this:-
Code: 
[COLOR=navy]Sub[/COLOR] MG04Jul29
[COLOR=navy]Dim[/COLOR] Rng     [COLOR=navy]As[/COLOR] Range
[COLOR=navy]Dim[/COLOR] Dn      [COLOR=navy]As[/COLOR] Range
[COLOR=navy]Dim[/COLOR] nRng    [COLOR=navy]As[/COLOR] Range
[COLOR=navy]Dim[/COLOR] Tri     [COLOR=navy]As[/COLOR] [COLOR=navy]String[/COLOR]
[COLOR=navy]Dim[/COLOR] Q       [COLOR=navy]As[/COLOR] Variant
[COLOR=navy]Dim[/COLOR] K
[COLOR=navy]Dim[/COLOR] nnRng   [COLOR=navy]As[/COLOR] Range
[COLOR=navy]Set[/COLOR] Rng = Range(Range("B2"), Range("B" & rows.count).End(xlUp))
[COLOR=navy]With[/COLOR] CreateObject("scripting.dictionary")
.CompareMode = vbTextCompare
    [COLOR=navy]For[/COLOR] [COLOR=navy]Each[/COLOR] Dn [COLOR=navy]In[/COLOR] Rng
        Tri = Dn & Dn(, 8) & Dn(, 9)
        [COLOR=navy]If[/COLOR] Not .Exists(Tri) [COLOR=navy]Then[/COLOR]
            .Add Tri, Array(Dn, nRng)
        [COLOR=navy]Else[/COLOR]
            Q = .Item(Tri)
            [COLOR=navy]If[/COLOR] Q(1) [COLOR=navy]Is[/COLOR] Nothing [COLOR=navy]Then[/COLOR]
            [COLOR=navy]Set[/COLOR] Q(1) = Dn
            [COLOR=navy]Else[/COLOR]
            [COLOR=navy]Set[/COLOR] Q(1) = Union(Q(1), Dn)
            [COLOR=navy]End[/COLOR] If
            .Item(Tri) = Q
        [COLOR=navy]End[/COLOR] If
[COLOR=navy]Next[/COLOR]
[COLOR=navy]Dim[/COLOR] t
[COLOR=navy]For[/COLOR] [COLOR=navy]Each[/COLOR] K [COLOR=navy]In[/COLOR] .keys
    [COLOR=navy]If[/COLOR] Not .Item(K)(1) [COLOR=navy]Is[/COLOR] Nothing [COLOR=navy]Then[/COLOR]
    [COLOR=navy]If[/COLOR] MsgBox("Do wish to Amalgamate cells :- " & chr(10) & .Item(K)(0).Address & " with " & .Item(K)(1).Address, vbOKCancel + vbQuestion, "Accept/Reject") = vbOK [COLOR=navy]Then[/COLOR]
         .Item(K)(0).Offset(, 5) = Application.sum(.Item(K)(1).Offset(, 5))
        .Item(K)(0).Offset(, 9).Resize(1) = Application.sum(.Item(K)(1).Offset(, 9))
            [COLOR=navy]If[/COLOR] nnRng [COLOR=navy]Is[/COLOR] Nothing [COLOR=navy]Then[/COLOR]
                [COLOR=navy]Set[/COLOR] nnRng = .Item(K)(1)
            [COLOR=navy]Else[/COLOR]
                 [COLOR=navy]Set[/COLOR] nnRng = Union(nnRng, .Item(K)(1))
            [COLOR=navy]End[/COLOR] If
    [COLOR=navy]End[/COLOR] If
    [COLOR=navy]End[/COLOR] If
[COLOR=navy]Next[/COLOR] K
[COLOR=navy]If[/COLOR] Not nnRng [COLOR=navy]Is[/COLOR] Nothing [COLOR=navy]Then[/COLOR]
    nnRng.EntireRow.Delete
[COLOR=navy]End[/COLOR] If
[COLOR=navy]End[/COLOR] With
[COLOR=navy]End[/COLOR] [COLOR=navy]Sub[/COLOR]
Regards Mick
 
Upvote 0
Hi Mick,

That code is pretty close to what I am after.

There is one issue that I have found and that it is not matching the values in column F, can this be ammended?

I have also noticed 2 things that I did not add in the original post, can the values of column G be added together like the values in column K and also the machine number in column B sometimes has a letter after the number can the code remove the letter ie 1a change to 1?

regards
 
Upvote 0
I realised after I sent the last code it was not quite correct with the adding.
Try this:-
Code: 
[COLOR="Navy"]Sub[/COLOR] MG05Jul06
[COLOR="Navy"]Dim[/COLOR] Rng     [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] Dn      [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] nRng    [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] Tri     [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]String[/COLOR]
[COLOR="Navy"]Dim[/COLOR] Q       [COLOR="Navy"]As[/COLOR] Variant
[COLOR="Navy"]Dim[/COLOR] K
[COLOR="Navy"]Dim[/COLOR] nnRng   [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Set[/COLOR] Rng = Range(Range("B2"), Range("B" & rows.count).End(xlUp))
[COLOR="Navy"]With[/COLOR] CreateObject("scripting.dictionary")
.CompareMode = vbTextCompare
    [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
        [COLOR="Navy"]If[/COLOR] Not IsNumeric(Right(Dn, 1)) [COLOR="Navy"]Then[/COLOR]
            Dn = Left(Dn, Len(Dn) - 1)
        [COLOR="Navy"]End[/COLOR] If
        
        Tri = Dn & Dn(, 8) & Dn(, 9)
        [COLOR="Navy"]If[/COLOR] Not .Exists(Tri) [COLOR="Navy"]Then[/COLOR]
            .Add Tri, Array(Dn, nRng)
        [COLOR="Navy"]Else[/COLOR]
            Q = .Item(Tri)
            [COLOR="Navy"]If[/COLOR] Q(1) [COLOR="Navy"]Is[/COLOR] Nothing [COLOR="Navy"]Then[/COLOR]
                [COLOR="Navy"]Set[/COLOR] Q(1) = Dn
            [COLOR="Navy"]Else[/COLOR]
                [COLOR="Navy"]Set[/COLOR] Q(1) = Union(Q(1), Dn)
            [COLOR="Navy"]End[/COLOR] If
            .Item(Tri) = Q
       [COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR]
[COLOR="Navy"]Dim[/COLOR] t
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] K [COLOR="Navy"]In[/COLOR] .keys
    [COLOR="Navy"]If[/COLOR] Not .Item(K)(1) [COLOR="Navy"]Is[/COLOR] Nothing [COLOR="Navy"]Then[/COLOR]
       [COLOR="Navy"]If[/COLOR] MsgBox("Do wish to Amalgamate Rows :- " & chr(10) & .Item(K)(0).Address & " with " & .Item(K)(1).Address, vbOKCancel + vbQuestion, "Accept/Reject") = vbOK [COLOR="Navy"]Then[/COLOR]
          .Item(K)(0).Offset(, 5) = .Item(K)(0).Offset(, 5) + Application.sum(.Item(K)(1).Offset(, 5))
          .Item(K)(0).Offset(, 9) = .Item(K)(0).Offset(, 9) + Application.sum(.Item(K)(1).Offset(, 9))
              [COLOR="Navy"]If[/COLOR] nnRng [COLOR="Navy"]Is[/COLOR] Nothing [COLOR="Navy"]Then[/COLOR]
                  [COLOR="Navy"]Set[/COLOR] nnRng = .Item(K)(1)
              [COLOR="Navy"]Else[/COLOR]
                   [COLOR="Navy"]Set[/COLOR] nnRng = Union(nnRng, .Item(K)(1))
             [COLOR="Navy"]End[/COLOR] If
      [COLOR="Navy"]End[/COLOR] If
    [COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR] K
[COLOR="Navy"]If[/COLOR] Not nnRng [COLOR="Navy"]Is[/COLOR] Nothing [COLOR="Navy"]Then[/COLOR]
    nnRng.EntireRow.Delete
[COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]With[/COLOR]
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]
Regards Mick
 
Upvote 0
Hi Mick,

That is almost perfect now, I still have an issue where I have 2 different values in column F and it ask to combine them. See below

Is it posible to show the rows it is asking to combine so that i can see the data to make sure that i do want to combine it?

Thanks so much for your help so far

Regards Damian

Excel Workbook
BCDEFGHIJK
3411006:1506:54YOA1030NaturalNatural00.0
3511106:5408:57YLA4326NaturalNatural00.0
3611208:5710:35YLA2472NaturalNatural00.0
Data
Excel 2010
 
Upvote 0
Try this:-
Code: 
[COLOR="Navy"]Sub[/COLOR] MG05Jul54
[COLOR="Navy"]Dim[/COLOR] Rng     [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] Dn      [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] nRng    [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] Tri     [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]String[/COLOR]
[COLOR="Navy"]Dim[/COLOR] Q       [COLOR="Navy"]As[/COLOR] Variant
[COLOR="Navy"]Dim[/COLOR] K
[COLOR="Navy"]Dim[/COLOR] Rw [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] nnRng   [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Set[/COLOR] Rng = Range(Range("B2"), Range("B" & rows.count).End(xlUp))
[COLOR="Navy"]With[/COLOR] CreateObject("scripting.dictionary")
.CompareMode = vbTextCompare
    [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
        [COLOR="Navy"]If[/COLOR] Not IsNumeric(Right(Dn, 1)) [COLOR="Navy"]Then[/COLOR]
            Dn = Left(Dn, Len(Dn) - 1)
        [COLOR="Navy"]End[/COLOR] If
        
        Tri = Dn & Dn(, 8) & Dn(, 9)
        [COLOR="Navy"]If[/COLOR] Not .Exists(Tri) [COLOR="Navy"]Then[/COLOR]
            .Add Tri, Array(Dn, nRng)
        [COLOR="Navy"]Else[/COLOR]
            Q = .Item(Tri)
            [COLOR="Navy"]If[/COLOR] Q(1) [COLOR="Navy"]Is[/COLOR] Nothing [COLOR="Navy"]Then[/COLOR]
                [COLOR="Navy"]Set[/COLOR] Q(1) = Dn
            [COLOR="Navy"]Else[/COLOR]
                [COLOR="Navy"]Set[/COLOR] Q(1) = Union(Q(1), Dn)
            [COLOR="Navy"]End[/COLOR] If
            .Item(Tri) = Q
       [COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR]
[COLOR="Navy"]Dim[/COLOR] txt [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]String,[/COLOR] sp
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] K [COLOR="Navy"]In[/COLOR] .keys
    [COLOR="Navy"]If[/COLOR] Not .Item(K)(1) [COLOR="Navy"]Is[/COLOR] Nothing [COLOR="Navy"]Then[/COLOR]
    [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Rw [COLOR="Navy"]In[/COLOR] .Item(K)(1)
        txt = txt & Rw.Offset(, 4).value & chr(10)
    [COLOR="Navy"]Next[/COLOR] Rw
           
   [COLOR="Navy"]If[/COLOR] MsgBox("Is this Result Acceptable" & chr(10) & .Item(K)(0).Offset(, 4).value & chr(10) & txt, vbOKCancel + vbQuestion, "Accept/Reject") = vbOK [COLOR="Navy"]Then[/COLOR]
   
          .Item(K)(0).Offset(, 5) = .Item(K)(0).Offset(, 5) + Application.sum(.Item(K)(1).Offset(, 5))
          .Item(K)(0).Offset(, 9) = .Item(K)(0).Offset(, 9) + Application.sum(.Item(K)(1).Offset(, 9))
              [COLOR="Navy"]If[/COLOR] nnRng [COLOR="Navy"]Is[/COLOR] Nothing [COLOR="Navy"]Then[/COLOR]
                  [COLOR="Navy"]Set[/COLOR] nnRng = .Item(K)(1)
              [COLOR="Navy"]Else[/COLOR]
                   [COLOR="Navy"]Set[/COLOR] nnRng = Union(nnRng, .Item(K)(1))
             [COLOR="Navy"]End[/COLOR] If
      [COLOR="Navy"]End[/COLOR] If
    [COLOR="Navy"]End[/COLOR] If
 txt = ""
 [COLOR="Navy"]Next[/COLOR] K
[COLOR="Navy"]If[/COLOR] Not nnRng [COLOR="Navy"]Is[/COLOR] Nothing [COLOR="Navy"]Then[/COLOR]
    nnRng.EntireRow.Delete
[COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]End[/COLOR] With
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]
Regards Mick
 
Upvote 0
Hi Mick,

i have just tried the ammended code.

I am still getting the same issue where it is asking me to if i want to combine different values in column F as in my last post.

The message box is good showing what to combine but is it possible to add the values from columns H,I & J to it as well.
 
Upvote 0
You must log in or register to reply here.

Similar threads

F
  • Question Question
Looking for help or guidance on a potential Macro project
Replies
1
Views
90
Rijnsent
Rijnsent
F
  • Solved
Search & Find String of Words
2
Replies
10
Views
157
Peter_SSs
Peter_SSs
S
  • Question Question
Excel VBA - Sort & Get Totals - Logic
Replies
4
Views
419
STARL0RD
S
A
  • Solved
VBA code to extract a table
Replies
5
Views
289
Anthony47
A
D
  • Question Question
Modify a worksheet without registering it as a change
Replies
1
Views
109
Kaper
Kaper

Forum statistics

Threads
1,224,609
Messages
6,179,881
Members
452,948
Latest member
Dupuhini

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top