Excel VBA Compare Data And Create Report

K

kashif.special2005

Active Member
Joined
Oct 26, 2009
Messages
443
Hi,

I have two sheets with data.

Note:- Data in both the sheet is around 90000, I am here showing only sample data for the task.

Sheet Name:- "Associate Tracker"

Sample Data:-

Column - AColumn - JColumn - SColumn - Z
Associate NameCalling DateConfirmationLocation
A1/4/2019YBrooklyn
A1/4/2019YMars
A1/4/2019YBrooklyn
A1/4/2019YBrooklyn
B1/4/2019NBrooklyn
B1/4/2019NBrooklyn
B1/4/2019NBrooklyn
A1/5/2019YBrooklyn
A1/5/2019YBrooklyn
A1/5/2019YBrooklyn
B1/5/2019YBrooklyn
B1/5/2019NBrooklyn
B1/5/2019NBrooklyn
C1/4/2019YBrooklyn
C1/4/2019NMars
C1/4/2019NMars
C1/4/2019NBrooklyn
B1/4/2019YBrooklyn
B1/6/2019YBrooklyn
C1/5/2019YBrooklyn
C1/5/2019YBrooklyn

<tbody>
</tbody>

Sheet Name:- "System Data"

Sample Data:-

Column - BColumn - PColumn - AB
Caller NameDateArea
A1/4/2019Brooklyn
A1/4/2019Mars
B1/4/2019Brooklyn
B1/4/2019Brooklyn
B1/4/2019Brooklyn
A1/5/2019Brooklyn
A1/5/2019Brooklyn
B1/5/2019Mars
C1/4/2019Mars
C1/4/2019Mars
B1/4/2019Brooklyn
B1/6/2019Brooklyn
C1/5/2019Mars
Z1/4/2019Brooklyn
Z1/6/2019Brooklyn
Z1/6/2019Brooklyn

<tbody>
</tbody>

Now I want to create 1st report from the sheet "Associate Tracker", and the report will look like below.

Report from the sheet:- "Associate Tracker"

LocationBrooklyn
ConfirmationY
Associate NameCalling DateValue
A1/4/20193
A1/5/20193
B1/4/20191
B1/5/20191
B1/6/20191
C1/4/20191
C1/5/20192
Grand Total12

<tbody>
</tbody>


And I want to create another report from the sheet "System Data", and the report will look like below.

Report from the sheet:- "System Data"


AreaBrooklyn
Caller NameDateValue
A1/4/20191
A1/5/20192
B1/4/20194
B1/6/20191
Z1/4/20191
Z1/6/20192
Grand Total11

<tbody>
</tbody>

Now from these two report I want to create a final "Comparison Report", and the comparison report will look like below.

Camparison Report:-

Associate NameCalling DateAssociate ValueSystem ValueTRUE/FALSE (Associate Value = System Value)Differences (Associate Value - System Value)
A1/4/201931FALSE2
A1/5/201932FALSE1
B1/4/201914FALSE-3
B1/5/20191Not ExistsFALSENot Applicable
B1/6/201911TRUE0
C1/4/20191Not ExistsFALSENot Applicable
C1/5/20192Not ExistsFALSENot Applicable
Grand Total128FALSE4

<tbody>
</tbody>

Please help me to create these three report, I have not idea how to create these reports.

I saw some post from the user "MickG", he used Dictionary object to create reports, Can we create these types of reports from Dictionary or any other method, please help me to achieve this task.

Please help me to achieve this task through VBA, because data is huge.

Thanks in advance.

Thanks
Kashif
 
Last edited:

Excel Facts

Back into an answer in Excel
Use Data, What-If Analysis, Goal Seek to find the correct input cell value to reach a desired result
Sort by date Sort by votes
Let's go, follow the following steps:
1. Create a sheet called "Reports"
2. Put the following code in the "Reports" sheet
3. To put the code in the "Reports" sheet, right click on the tab and in the menu select the option "View code"
4. Paste the following code

Code: 
Private Sub Worksheet_Change(ByVal Target As Range)
'
'   Create Reports
'
    If Target.Count > 1 Then Exit Sub
    If Not Intersect(Target, Range("B2:B3")) Is Nothing Then
        If Range("B2").Value = "" Or Range("B3").Value = "" Then Exit Sub
        '
        Application.ScreenUpdating = False
        Application.EnableEvents = False
        
        Set h1 = Sheets("Associate Tracker")
        Set h2 = Sheets("System Data")
        Set h3 = Sheets("Reports")
        h3.Rows("7:" & Rows.Count).ClearContents
        '
        'Report 1
        '
        If h1.AutoFilterMode Then h1.AutoFilterMode = False
        u1 = h1.Range("Z" & Rows.Count).End(xlUp).Row
        h1.Range("A1:Z" & u1).AutoFilter Field:=26, Criteria1:=h3.Range("B2")
        h1.Range("A1:Z" & u1).AutoFilter Field:=19, Criteria1:=h3.Range("B3")
        h1.Range("A2:A" & u1).Copy h3.Range("A7")   'name
        h1.Range("J2:J" & u1).Copy h3.Range("B7")   'date
        '
        u3 = h3.Range("A" & Rows.Count).End(xlUp).Row
        With Range("C7:C" & u3)
            .FormulaR1C1 = "=COUNTIFS(R7C1:R" & u3 & "C1,RC[-2],R7C2:R" & u3 & "C2,RC[-1])"
            .Value = .Value
        End With
        h3.Range("A6:C" & u3).RemoveDuplicates Columns:=Array(1, 2), Header:=xlYes
        u3 = h3.Range("A" & Rows.Count).End(xlUp).Row
        With h3.Sort
            .SortFields.Clear
            .SortFields.Add Key:=h3.Range("A7:A" & u3)
            .SortFields.Add Key:=h3.Range("B7:B" & u3)
            .SetRange h3.Range("A6:C" & u3): .Header = xlYes: .MatchCase = False
            .Orientation = xlTopToBottom: .SortMethod = xlPinYin: .Apply
        End With
        '
        'Report 2
        '
        If h2.AutoFilterMode Then h2.AutoFilterMode = False
        u2 = h2.Range("AB" & Rows.Count).End(xlUp).Row
        h2.Range("A1:AB" & u2).AutoFilter Field:=28, Criteria1:=h3.Range("B2")
        h2.Range("B2:B" & u2).Copy h3.Range("E7")   'name
        h2.Range("P2:P" & u1).Copy h3.Range("F7")   'date
        '
        u3 = h3.Range("E" & Rows.Count).End(xlUp).Row
        With Range("G7:G" & u3)
            .FormulaR1C1 = "=COUNTIFS(R7C5:R" & u3 & "C5,RC[-2],R7C6:R" & u3 & "C6,RC[-1])"
            .Value = .Value
        End With
        h3.Range("E6:G" & u3).RemoveDuplicates Columns:=Array(1, 2), Header:=xlYes
        u3 = h3.Range("E" & Rows.Count).End(xlUp).Row
        With h3.Sort
            .SortFields.Clear
            .SortFields.Add Key:=h3.Range("E7:E" & u3)
            .SortFields.Add Key:=h3.Range("F7:F" & u3)
            .SetRange h3.Range("E6:G" & u3): .Header = xlYes: .MatchCase = False
            .Orientation = xlTopToBottom: .SortMethod = xlPinYin: .Apply
        End With
        '
        'Report 3
        '
        u3 = h3.Range("A" & Rows.Count).End(xlUp).Row
        h3.Range("A7:C" & u3).Copy h3.Range("I7")
        u3 = h3.Range("E" & Rows.Count).End(xlUp).Row
        For i = 7 To u3
            Set r = h3.Columns("I")
            Set b = r.Find(h3.Cells(i, "E"), LookAt:=xlWhole)
            existe = False
            If Not b Is Nothing Then
                celda = b.Address
                Do
                    'detalle
                    If h3.Cells(b.Row, "J").Value = h3.Cells(i, "F").Value Then
                        h3.Cells(b.Row, "L").Value = h3.Cells(i, "G").Value
                        existe = True
                        Exit Do
                    End If
                    Set b = r.FindNext(b)
                Loop While Not b Is Nothing And b.Address <> celda
            End If
            If existe = False Then
                u4 = h3.Range("I" & Rows.Count).End(xlUp).Row + 1
                h3.Range("E" & i & ":F" & i).Copy h3.Range("I" & u4)
                h3.Range("G" & i & ":G" & i).Copy h3.Range("L" & u4)
            End If
        Next
        '
        u3 = h3.Range("I" & Rows.Count).End(xlUp).Row
        With h3.Sort
            .SortFields.Clear
            .SortFields.Add Key:=h3.Range("I7:I" & u3)
            .SortFields.Add Key:=h3.Range("J7:J" & u3)
            .SetRange h3.Range("I6:N" & u3): .Header = xlYes: .MatchCase = False
            .Orientation = xlTopToBottom: .SortMethod = xlPinYin: .Apply
        End With
        On Error Resume Next
        h3.Range("K7:L" & u3).SpecialCells(xlCellTypeBlanks) = "Not Exists"
        On Error GoTo 0
        h3.Range("I" & u3 + 1).Value = "Grand Total"
        h3.Range("K" & u3 + 1).Value = WorksheetFunction.Sum(h3.Range("K7:K" & u3))
        h3.Range("L" & u3 + 1).Value = WorksheetFunction.Sum(h3.Range("L7:L" & u3))
        With h3.Range("M7:M" & u3 + 1)
            .FormulaR1C1 = "=IF(RC[-2]=RC[-1],""TRUE"",""FALSE"")"
            .Value = .Value
        End With
        With h3.Range("N7:N" & u3 + 1)
            .FormulaR1C1 = "=IF(OR(RC[-3]=""Not Exists"",RC[-2]=""Not Exists""),""Not Applicable"",RC[-3]-RC[-2])"
            .Value = .Value
        End With
        Application.ScreenUpdating = True
        Application.EnableEvents = True
    End If
End Sub
'
Private Sub Worksheet_Activate()
'
'   Create Data Validation on cell B2 and B3
'
    Application.EnableEvents = False
    Application.ScreenUpdating = False
    Set h1 = Sheets("Associate Tracker")
    Set h2 = Sheets("System Data")
    Set h3 = Sheets("Reports")
    'h3.Rows("7:" & Rows.Count).ClearContents
    If h1.AutoFilterMode Then h1.AutoFilterMode = False
    If h2.AutoFilterMode Then h2.AutoFilterMode = False
    u1 = h1.Range("Z" & Rows.Count).End(xlUp).Row
    h1.Range("Z1:Z" & u1).Copy
    h3.Range("Z1").PasteSpecial Paste:=xlPasteValues
    u3 = h3.Range("Z" & Rows.Count).End(xlUp).Row
    h3.Range("Z1:Z" & u3).RemoveDuplicates Columns:=1, Header:=xlYes
    u3 = h3.Range("Z" & Rows.Count).End(xlUp).Row
    With h3.Range("B2").Validation
        .Delete
        .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _
            Operator:=xlBetween, Formula1:="=Z2:Z" & u3
        .IgnoreBlank = True
        .InCellDropdown = True
        .InputTitle = ""
        .ErrorTitle = ""
        .InputMessage = ""
        .ErrorMessage = ""
        .ShowInput = True
        .ShowError = True
    End With
    h3.Range("AA2").Value = "Y"
    h3.Range("AA3").Value = "N"
    With h3.Range("B3").Validation
        .Delete
        .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _
            Operator:=xlBetween, Formula1:="=AA2:AA3"
        .IgnoreBlank = True
        .InCellDropdown = True
        .InputTitle = ""
        .ErrorTitle = ""
        .InputMessage = ""
        .ErrorMessage = ""
        .ShowInput = True
        .ShowError = True
    End With
    Range("B2").Select
    Application.EnableEvents = True
End Sub


On the "Reports" sheet, put the following structure:

ABCDEFGHIJKLMN
1
2Location
3Confirmation
4
5Report 1Report 2Report 3
6NameDateValueNameDateValueNameDateA ValueS ValueTrue / FalseDiff
7

<tbody>
</tbody>




It works as follows, select one of your sheets, now select the "Reports" sheet, the locations in cell B2 are loaded automatically. In cell B3 "Y" and "N" are loaded.
Now, select a location and confirmation. In automatic, the 3 reports are generated.

See image:
https://www.dropbox.com/s/jr16jj5bobi259a/reports.jpg?dl=0

Regards Dante Amor
 
Upvote 0
You must log in or register to reply here.

Similar threads

E
  • Solved
VlookUp multiple same value ?
Replies
5
Views
249
Sufiyan97
Sufiyan97
Anigito
  • Question
Get Webpage Title Text by URL Generated in MS Excel
Replies
1
Views
404
Anigito
Anigito
P
  • Question
Turning OFF the visibility of a horizontal (category) axis labels if certain conditions apply
Replies
1
Views
390
NdNoviceHlp
NdNoviceHlp
M
  • Solved
Create array based on cell reference
2
Replies
14
Views
515
Fluff
Fluff
H
  • Question
VBA to Create a speaker object
Replies
0
Views
106
hsandeep
H

Forum statistics

Threads
1,214,652
Messages
6,120,747
Members
448,989
Latest member
mariah3

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