Excel VBA Course
Excel VBA Course - From Beginner to Expert

200+ Video Lessons
50+ Hours of Video
200+ Excel Guides

Become a master of VBA and Macros in Excel and learn how to automate all of your tasks in Excel with this online course. (No VBA experience required.)

View Course

merge duplicates data for each sheet separately

0

good morning !

sorry  Guys  I come  back  again  for  the  same  file .

actually  I  try  making  to merge  duplicates   data for  each  sheet  separately  not  merge  for  all  of  the  sheets .

so  when  merge duplicate  sheet REPORT  should  show  the  result in sheet RESULT,   also merge duplicate  sheet REPORT2  should  show  the  result in sheet RESULT1,  

should  merge  duplicates data  for  each  sheet  individually

I  put  the  result in sheet RESULT= sheet REPORT1, RESULT1=REPORT2 . see the  bold  lines  in  the  code   what  I  try  it .

Sub output()
Dim sh As Worksheet, dic As Object, rn As Range, a, n&
Dim m As Long
Set dic = CreateObject("scripting.dictionary")
For Each sh In ThisWorkbook.Sheets
If (Not UCase$(sh.Name) Like "RESULT*") * (sh.[a1] = "DATE") Then
 a = sh.Cells(1).CurrentRegion.Value: a(1, 1) = "ITEM"
    'If sh.Name <> "output" Then
        For Each rn In Intersect(sh.[a1].CurrentRegion.Resize(, 1).Offset(, 1), sh.[a1].CurrentRegion.Offset(1))
             If dic.exists(rn.Value) Then
                a = dic(rn.Value)
                a(1) = a(1) & "," & Right(rn(1, 2), 3)
                a(6) = a(6) + rn(1, 7).Value 'a(6) is stored QTY, rn(1, 7) collects QTY from sh
                a(7) = a(7) + rn(1, 9).Value 'a(7) is stored TOTAL PRICE, rn(1, 9) collects TOTAL PRICE from sh
                If InStr(a(2) & ",", rn(1, 3).Value & ",") = 0 Then a(2) = a(2) & "," & rn(1, 3).Value
                dic(rn.Value) = a
             Else
                ReDim a(8) ' only needs 8
                For n = 0 To 8
                    a(n) = rn.Offset(, n).Value
                    'a(6) gets QTY; 'a(7) gets UNIT PRICE ;a(8) gets TOTAL PRICE
                Next
                'overwrite a(7) to store TOTAL PRICE (and for output)
                a(7) = a(8)
                'a(9) = 1: a(9) = rn(1, 8)
                dic(rn.Value) = a
            End If
        Next
    End If
Next
m = m + 1
If Not Evaluate("isref('Result" & m & "'!a1)") Then
                Sheets.Add(, Sheets(Sheets.Count)).Name = "RESULT" & m
            End If
            With Sheets("Result" & m).Cells(A2).Resize(dic.Count)
   ' With Sheets("output").[a2].Resize(dic.Count)
        .Value = Evaluate("row(1:" & dic.Count & ")")
        .Offset(, 1).Resize(, 8) = Application.Transpose(Application.Transpose(dic.Items))
        .Offset(, 3) = Evaluate(Replace("LEFT(#,6)&SUBSTITUTE(#,LEFT(#,6),)", "#", .Offset(, 3).Address))
    End With
End Sub
Answer
Discuss

Answers

0
Selected Answer

Hi Maklal

Wasn't sure what your question was but not see that your macro doesn't work correctly.

In the attached file, I've modified your code so that writing results is within your loop of sheets i.e. per sheet sh passing your IF test. To make the results independent of each other, I've added a line after that IF test to clear the dictionary dic BEFORE the macro starts to scan the sheet sh and developing the (new) dictionary keys and values. I've illustrated this by putting too much data on sheets RESULT1 and RESUT2 as the file leaves me (please check before running macro)..

I've also added lines to clear the results on any RESULT* sheet (in case they were bigger than the current scan) and to add headings, borders and to autofit columns. Note that if an existing sheet has number formatting, it is not lost in clearing the sheet e.g column I of RESULT1 has a number format set.

The changes (and comments are in bold below:

Sub output()
Dim sh As Worksheet, dic As Object, rn As Range, a, n&
Dim m As Long

Set dic = CreateObject("scripting.dictionary")

For Each sh In ThisWorkbook.Sheets
If (Not UCase$(sh.Name) Like "RESULT*") * (sh.[a1] = "DATE") Then
    '### clear (old) dictionary
    dic.RemoveAll
    a = sh.Cells(1).CurrentRegion.Value: a(1, 1) = "ITEM"
    'If sh.Name <> "output" Then
        For Each rn In Intersect(sh.[a1].CurrentRegion.Resize(, 1).Offset(, 1), sh.[a1].CurrentRegion.Offset(1))
             If dic.exists(rn.Value) Then
                a = dic(rn.Value)
                a(1) = a(1) & "," & Right(rn(1, 2), 3)
                a(6) = a(6) + rn(1, 7).Value 'a(6) is stored QTY, rn(1, 7) collects QTY from sh
                a(7) = a(7) + rn(1, 9).Value 'a(7) is stored TOTAL PRICE, rn(1, 9) collects TOTAL PRICE from sh
                If InStr(a(2) & ",", rn(1, 3).Value & ",") = 0 Then a(2) = a(2) & "," & rn(1, 3).Value
                dic(rn.Value) = a
             Else
                ReDim a(8)
                For n = 0 To 8
                    a(n) = rn.Offset(, n).Value
                    'a(6) gets QTY; 'a(7) gets UNIT PRICE ;a(8) gets TOTAL PRICE
                Next
                'overwrite a(7) to store TOTAL PRICE (and for output)
                a(7) = a(8)
                dic(rn.Value) = a
            End If
        Next rn
    'End If '### moved down
    ' Next '### moved down

    m = m + 1
    If Not Evaluate("isref('Result" & m & "'!a1)") Then
                Sheets.Add(, Sheets(Sheets.Count)).Name = "RESULT" & m
            End If
        With Worksheets("Result" & m) '### was Sheets("Result" & m).Cells(A2)
            ' With Sheets("output").[a2].Resize(dic.Count)
            'clear any previous results
            .UsedRange.EntireRow.Delete
            With .Range("A2").Resize(dic.Count)
                ' ### add column headings
                .Resize(1, 9).Offset(-1, 0).Value = Array("Item", "Batch", "Invoice number", "Customer name", "Brand", "Type", "Manufacture", "Qty", "Total")
                .Value = Evaluate("row(1:" & dic.Count & ")")
                .Offset(, 1).Resize(, 8) = Application.Transpose(Application.Transpose(dic.Items))
                .Offset(, 3) = Evaluate(Replace("LEFT(#,6)&SUBSTITUTE(#,LEFT(#,6),)", "#", .Offset(, 3).Address))
                '### fit results to width
                .Resize(1, 9).EntireColumn.AutoFit
                ' ### draw simple borders around cells
                .CurrentRegion.Borders.LineStyle = xlContinuous
            End With
     End With
    End If ' ### moved from above
Next sh ' ### moved from above

End Sub

Personally, I would stop using counter m (and sheet names like RESULT1) and use:

Sheets.Add(, Sheets(Sheets.Count)).Name = "Summary for " * sh.Name

so you have tabs like "Summary for REPORT1" or even "Summary for AUGUST 2022" which are much easier to link to the source sheet names. I leave you to change other bits of code if you want to do that.

Hope this fixes things for you.

Discuss

Discussion

thanks  John this  is  exactly  what  I  want  it .
just   I  note  strange  case about  numberformat . it  shows  in  result1   but  delete  it  from  result2 .  i try  using  from  cell format  but  the  code  delete  it  just  from  result2 , also   I try  to add  this  line 
.Offset(, 7).Resize(1, 9).NumberFormat = "#,##0.00"
but  just  work  in  row2 !!
Malkal (rep: 22) Aug 3, '22 at 3:58 am
Thanks for selecting my Answer, Malkal.

Your statement doesn't work because: your line applies to $H$2:$P$2 (so you see the format appear in H2:I2 only).

Use this instead (the change in bold below to be at that place):
            With .Range("A2").Resize(dic.Count)
                ' ### add column headings
                .Resize(1, 9).Offset(-1, 0).Value = Array("Item", "Batch", "Invoice number", "Customer name", "Brand", "Type", "Manufacture", "Qty", "Total")
                .Value = Evaluate("row(1:" & dic.Count & ")")
                .Offset(, 1).Resize(, 8) = Application.Transpose(Application.Transpose(dic.Items))
                .Offset(, 3) = Evaluate(Replace("LEFT(#,6)&SUBSTITUTE(#,LEFT(#,6),)", "#", .Offset(, 3).Address))
                'format column 9 (I)
                .Offset(0, 8).Resize(dic.Count, 1).NumberFormat = "#,##0.00"
                '### fit results to width
                .Resize(1, 9).EntireColumn.AutoFit
                ' ### draw simple borders around cells
                .CurrentRegion.Borders.LineStyle = xlContinuous
            End With
     End With
    End If ' ### moved from above
Next sh ' ### moved from above
 
End Sub
John_Ru (rep: 6102) Aug 3, '22 at 4:40 am
Hi john ,
thanks  for  clarification and  correction!
Malkal (rep: 22) Aug 3, '22 at 5:11 am
NP, Malkal
John_Ru (rep: 6102) Aug 3, '22 at 5:12 am
Add to Discussion


Answer the Question

You must create an account to use the forum. Create an Account or Login