asked on

Compare data of two tables in excel

Dear Experts,
We came across a requirement where in we have two different data having one common column of Group No..
As shown in attached excel file we want the two types of results to compare check the data.

Please suggest macro codes to achieve this,

Regards,
Nilesh.
Example-Cpmpare.xls

Tracy

Have a look at Dave's article. It explains how to combine multiples files and multiple sheets.

https://www.experts-exchange.com/Software/Office_Productivity/Office_Suites/MS_Office/Excel/A_2804-Code-to-compile-all-worksheets-from-either-a-all-Excel-workbooks-in-a-folder-or-b-a-specific-Excel-workbook.html

tnilesh2

ASKER

Dear Broomee9,
Thanks for looking into, I have checked the artical but found that the given macro codes copies the data of all the sheets & arranged in a single sheet,
But my requirement is something different (as mentioned in attached file).
Please look into & suggest.
Thanks,
Nilesh.

Robberbaron (robr)

looking at your example, you actually want to match on TWO columns of data; Group is not unique. Add WorkCentre or OpAcct

But "Work Centre" seems to be grouped by only portion of text. eg C&C , not C&C-06 . F&G, not F&G-05
What about FS-SP-01 ? ie cant just check on the portion before the numeral ?

I'll work on something using Group + OpAcct.

Robberbaron (robr)

paste the code into a module and run the R1 macro.

R2 is just a stub as it is a bit more work to do the summaries so need o confirm on right path before attempting.

Sub R1()
'
' Robberbaron EE
' v1 19.Sept.2010
'
    Dim wsData As Worksheet
    Dim rOpData As Range, rMasterData As Range
    
    Dim wsR1 As Worksheet, rResult1 As Range
    
    Dim lRowStart As Long, lRowEnd As Long
    Dim sTmp As String
    
    'cleanup
    On Error Resume Next
    Application.DisplayAlerts = False
    ActiveWorkbook.Sheets("Data-tmp").Delete
    ActiveWorkbook.Sheets("Result-1").Delete
    ActiveWorkbook.Sheets("Result-2").Delete
    Application.DisplayAlerts = True
    
    
    On Error GoTo 0
    
    
    'copy data to end of workbook for modification
    Sheets("Data").Select
    Sheets("Data").Copy After:=Sheets(ActiveWorkbook.Sheets.Count)
    Set wsData = ActiveWorkbook.Sheets(ActiveWorkbook.Sheets.Count)
    wsData.Name = "Data-tmp"
    
    'assume format unchanged
    Set rOpData = RealUsedRange(Columns("K:K"))
    lRowStart = rOpData.Row
    lRowEnd = rOpData.Row + rOpData.Rows.Count - 1
    
    'insert new sort index col
    Columns("K:K").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    'add sort index
    sTmp = "K" & Format(lRowStart, "0") & ":" & "K" & Format(lRowEnd, "0")
    Range(sTmp).FormulaR1C1 = "=TEXT(RC[-2],""0="") & TEXT(RC[-1],""00"")"
    wsData.Cells(lRowStart, 11) = "Index"
    

    Application.CutCopyMode = False
        
    With wsData.Sort
        .SortFields.Clear
        sTmp = "K" & Format(lRowStart + 1, "0") & ":" & "K" & Format(lRowEnd, "0")
        .SortFields.Add Key:=Range(sTmp), _
            SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
            
        sTmp = "N" & Format(lRowStart + 1, "0") & ":" & "N" & Format(lRowEnd, "0")
        .SortFields.Add Key:=Range(sTmp), _
            SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
            
        sTmp = "I" & Format(lRowStart, "0") & ":" & "N" & Format(lRowEnd, "0")
        .SetRange Range(sTmp)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        

        .Apply
    End With
    'now have useful source data range
    sTmp = "I" & Format(lRowStart, "0") & ":" & "N" & Format(lRowEnd, "0")
    Set rOpData = wsData.Range(sTmp)
    sTmp = "K" & Format(lRowStart + 1, "0") & ":" & "K" & Format(lRowEnd, "0")
    Set rOpIndex = wsData.Range(sTmp)
    
    Set rMasterData = RealUsedRange(Range("B4:G65536"))

    
    'now insert the Results1 page
    Set wsR1 = ActiveWorkbook.Sheets.Add(After:=ActiveWorkbook.Sheets("Data"), Count:=1)
    wsR1.Name = "Result-1"
    'format the column widths
    wsR1.Columns(1).ColumnWidth = 8.29
    wsR1.Columns(2).ColumnWidth = 16.71
    wsR1.Columns(3).ColumnWidth = 10.57
    wsR1.Columns(4).ColumnWidth = 9.57
    wsR1.Columns(5).ColumnWidth = 12.71
    wsR1.Columns(6).ColumnWidth = 19.29
    wsR1.Columns(7).ColumnWidth = 10
    wsR1.Columns(8).ColumnWidth = 16.71
    wsR1.Columns(9).ColumnWidth = 9.23
    'wsR1.Columns("A:A").Width = 8.29

    
    Set rResult1 = wsR1.Range("A1")
    
    'copy headers
    rMasterData.Cells(1, 1).Resize(, 6).Copy rResult1
    rOpData.Cells(1, 4).Resize(, 3).Copy rResult1.Offset(0, 6)
    
    imastercounter = 1: iOpCounter = 1: ioutputrow = 1
    For imastercounter = 1 To rMasterData.Rows.Count - 1
        'loop through the masterdata
        'copy the master record to output
        rMasterData.Offset(imastercounter, 0).Cells(1, 1).Resize(, 6).Copy rResult1.Offset(ioutputrow, 0)
        sIndex = Format(rMasterData.Offset(imastercounter, 0).Cells(1, 1).Value, "0=") & Format(rMasterData.Offset(imastercounter, 3).Cells(1, 1).Value, "00")
        
        'find the index in OpData.
        With rOpIndex
            Set ri1 = .Find(What:=sIndex, _
                            After:=.Cells(.Cells.Count), _
                            LookIn:=xlValues, _
                            LookAt:=xlWhole, _
                            SearchOrder:=xlByRows, _
                            SearchDirection:=xlNext, _
                            MatchCase:=False)
            Set ri2 = .Find(What:=sIndex, _
                            After:=.Cells(1), _
                            LookIn:=xlValues, _
                            LookAt:=xlWhole, _
                            SearchOrder:=xlByRows, _
                            SearchDirection:=xlPrevious, _
                            MatchCase:=False)
            If ri1 Is Nothing Or ri2 Is Nothing Then
                MsgBox "Nothing found"
            End If
        End With
        Range(ri1.Offset(0, 1), ri2.Offset(0, 3)).Copy rResult1.Offset(ioutputrow, 6)
        
        'move the results line down
        ioutputrow = ioutputrow + ri2.Row - ri1.Row + 1
    Next
    ActiveSheet.Range("A1").Select

    'cleanup
    On Error Resume Next
    Application.DisplayAlerts = False
    ActiveWorkbook.Sheets("Data-tmp").Delete
    Application.DisplayAlerts = True
    
    
    On Error GoTo 0

End Sub

Sub R2()
    Dim wsR1 As Worksheet, wsR2 As Worksheet
    
    'now insert the Results2 page
    Set wsR2 = ActiveWorkbook.Sheets.Add(After:=wsR1, Count:=1)

End Sub

Public Function RealUsedRange(src As Range) As Range
    'http://www.vbaexpress.com/kb/getarticle.php?kb_id=82
    'by DRJ
    Dim FirstRow        As Long
    Dim LastRow         As Long
    Dim FirstColumn     As Integer
    Dim LastColumn      As Integer
    Dim rX As Long, cX As Integer
    On Error Resume Next
     
    rX = src.Rows.Count: cX = src.Columns.Count
    
    FirstRow = src.Cells.Find(What:="*", After:=src.Cells(rX, cX), LookIn:=xlValues, _
        LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext).Row
     
    FirstColumn = src.Cells.Find(What:="*", After:=src.Cells(rX, cX), LookIn:=xlValues, _
        LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext).Column
     
    LastRow = src.Find(What:="*", After:=src.Cells(1, 1), LookIn:=xlValues, _
        LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
     
    LastColumn = src.Find(What:="*", After:=src.Cells(1, 1), LookIn:=xlValues, _
        LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
     
    Set RealUsedRange = Range(Cells(FirstRow, FirstColumn), Cells(LastRow, LastColumn))
     
    On Error GoTo 0
     
End Function

Open in new window

tnilesh2

ASKER

Dear Robberbaron,
Thanks for looking into,

Let me answer your queries posted in your first reply –

looking at your example, you actually want to match on TWO columns of data; Group is not unique. Add WorkCentre or OpAcct - As shown in file, I want to compare the actual usage of work centers against the work center given in master data where the common string bet two data is “Group No.” & “OpAc No..”.

But "Work Centre" seems to be grouped by only portion of text. eg C&C , not C&C-06 . F&G, not F&G-05
What about FS-SP-01 ? ie cant just check on the portion before the numeral ? – No, we do not want to group work center by portion of text as shown in file, every work center is mentioned individually.

I'll work on something using Group + OpAcct. – Yes absolutely correct.

Once again I thank you for the solution (macro codes) given by you.

But, I tried the codes by inserting these macro codes as Module & found that excel is not showing option to “Run” the macro (the updated file is attached herewith).

Please suggest how to tackle this problem, may be I am doing it wrongly.

Regards,
Nilesh.
Example-Cpmpare-1.xls

Robberbaron (robr)

you are correct. The macro needs to be named RES1 , not R1 which conflicts with the cell R1.

just change the Sub R1() to be sub RES1()

if this looks ok, can then look at the Result2 requirement which is a bit harder due to the summations required. need to think about the most efficient method.

Robberbaron (robr)

can we change the order in which WorkCtr is presented ? ie ascending or decending ratehr than mixed ?

tnilesh2

ASKER

Dear Robber Baron,
I have changed the Sub R1() to be sub RES1() similarly changed the Sub R2() to be sub RES2() & execute the macro but some Compile Error has occurred (the snap is attached herewith).
Please suggest how to overcome the error.
Regarding your second query of order of work center (in Required Result - 2) - our goal is to show no. of occurrence of each work center against work center of same "Group + OpAcct", if it is achieved then we can re-arrange it as per our convenience.
Thanks again,
Looking forward for your valuable help,
Regards,
Nilesh.

untitled.bmp
Example-Cpmpare-2.xls

Robberbaron (robr)

I have merged the routines into one.

output is correct in detail, formatting may need correction by yourself.

Option Explicit

Sub MakeResults()

'
' Robberbaron @ EE
' v1 19.Sept.2010
' v2 21.Sept.2010

    'cleanup
    On Error Resume Next
    Application.DisplayAlerts = False
    ActiveWorkbook.Sheets("Data-tmp").Delete
    ActiveWorkbook.Sheets("Result-1").Delete
    ActiveWorkbook.Sheets("Result-2").Delete
    Application.DisplayAlerts = True
    
    Dim wsData As Worksheet
    Dim rOpData As Range, rMasterData As Range
    Dim rOpDataGroup As Range, rOpIndex As Range
    
    Dim wsR1 As Worksheet, rResult1 As Range, iOutputrow1 As Integer
    
    Dim wsR2 As Worksheet, rResult2 As Range, iOutputrow2 As Integer
    
    Dim lRowStart As Long, lRowEnd As Long
    Dim sTmp As String, vItem As Variant, sIndex As String
    Dim rI1 As Range, rI2 As Range
    Dim iMasterCounter As Integer, iOpCounter As Integer
    
    Dim colUnique As Collection
    
    'copy data to end of workbook for modification
    Sheets("Data").Select
    Sheets("Data").Copy After:=Sheets(ActiveWorkbook.Sheets.count)
    Set wsData = ActiveWorkbook.Sheets(ActiveWorkbook.Sheets.count)
    wsData.Name = "Data-tmp"
    
    
    
    On Error GoTo 0
    

    
    'assume format unchanged
    Set rOpData = RealUsedRange(Columns("K:K"))
    lRowStart = rOpData.Row
    lRowEnd = rOpData.Row + rOpData.Rows.count - 1
    
    
    'insert new sort index col
    Columns("K:K").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    'add sort index
    sTmp = "K" & Format(lRowStart, "0") & ":" & "K" & Format(lRowEnd, "0")
    Range(sTmp).FormulaR1C1 = "=TEXT(RC[-2],""0="") & TEXT(RC[-1],""00"")"
    wsData.Cells(lRowStart, 11) = "Index"
    

    Application.CutCopyMode = False
        
    With wsData.Sort
        .SortFields.Clear
        sTmp = "K" & Format(lRowStart + 1, "0") & ":" & "K" & Format(lRowEnd, "0")
        .SortFields.Add key:=Range(sTmp), _
            SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
            
        sTmp = "N" & Format(lRowStart + 1, "0") & ":" & "N" & Format(lRowEnd, "0")
        .SortFields.Add key:=Range(sTmp), _
            SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
            
        sTmp = "I" & Format(lRowStart, "0") & ":" & "N" & Format(lRowEnd, "0")
        .SetRange Range(sTmp)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        

        .Apply
    End With
    'now have useful source data range
    sTmp = "I" & Format(lRowStart, "0") & ":" & "N" & Format(lRowEnd, "0")
    Set rOpData = wsData.Range(sTmp)
    sTmp = "K" & Format(lRowStart + 1, "0") & ":" & "K" & Format(lRowEnd, "0")
    Set rOpIndex = wsData.Range(sTmp)
    
    Set rMasterData = RealUsedRange(Range("B4:G65536"))

    
    'now insert the Results1 page
    Set wsR1 = ActiveWorkbook.Sheets.Add(After:=ActiveWorkbook.Sheets("Data"), count:=1)
    wsR1.Name = "Result-1"
    'format the column widths
    wsR1.Columns(1).ColumnWidth = 8.29
    wsR1.Columns(2).ColumnWidth = 16.71
    wsR1.Columns(3).ColumnWidth = 10.57
    wsR1.Columns(4).ColumnWidth = 9.57
    wsR1.Columns(5).ColumnWidth = 12.71
    wsR1.Columns(6).ColumnWidth = 19.29
    wsR1.Columns(7).ColumnWidth = 10
    wsR1.Columns(8).ColumnWidth = 16.71
    wsR1.Columns(9).ColumnWidth = 9.23
    
    Set rResult1 = wsR1.Range("A1")
    
    
    'now insert the Results2 page
    wsR1.Copy After:=wsR1
    Set wsR2 = ActiveWorkbook.ActiveSheet
    wsR2.Name = "Result-2"
    
    Set rResult2 = wsR2.Range("A1")
        
    'copy headers
    rMasterData.Cells(1, 1).Resize(, 6).Copy rResult1
    rOpData.Cells(1, 4).Resize(, 3).Copy rResult1.Offset(0, 6)
    
    rMasterData.Cells(1, 1).Resize(, 6).Copy rResult2
    rOpData.Cells(1, 4).Resize(, 3).Copy rResult2.Offset(0, 6)
    rResult2.Offset(0, 7).Value = "Occurance"
    
    
    'now do the data
    iMasterCounter = 1: iOpCounter = 1
    iOutputrow1 = 1: iOutputrow2 = 1
    For iMasterCounter = 1 To rMasterData.Rows.count - 1
        'loop through the masterdata
        'copy the master record to output
        rMasterData.Offset(iMasterCounter, 0).Cells(1, 1).Resize(, 6).Copy rResult1.Offset(iOutputrow1, 0)
        
        rMasterData.Offset(iMasterCounter, 0).Cells(1, 1).Resize(, 6).Copy rResult2.Offset(iOutputrow2, 0)

        sIndex = Format(rMasterData.Offset(iMasterCounter, 0).Cells(1, 1).Value, "0=") & Format(rMasterData.Offset(iMasterCounter, 3).Cells(1, 1).Value, "00")
        
        'find the index in OpData.
        With rOpIndex
            Set rI1 = .Find(What:=sIndex, _
                            After:=.Cells(.Cells.count), _
                            LookIn:=xlValues, _
                            LookAt:=xlWhole, _
                            SearchOrder:=xlByRows, _
                            SearchDirection:=xlNext, _
                            MatchCase:=False)
            Set rI2 = .Find(What:=sIndex, _
                            After:=.Cells(1), _
                            LookIn:=xlValues, _
                            LookAt:=xlWhole, _
                            SearchOrder:=xlByRows, _
                            SearchDirection:=xlPrevious, _
                            MatchCase:=False)
            If rI1 Is Nothing Or rI2 Is Nothing Then
                MsgBox "Nothing found"
            End If
        End With
        
        Set rOpDataGroup = Range(rI1.Offset(0, 1), rI2.Offset(0, 3))
        
        'output results 1
        rOpDataGroup.Copy rResult1.Offset(iOutputrow1, 6)
                
        'move the results line down
        iOutputrow1 = iOutputrow1 + rI2.Row - rI1.Row + 1
        
        'now do results 2
        'get OpData sections
        Set colUnique = GetUniqueValues(rOpDataGroup.Columns(1))
        For Each vItem In colUnique
            Debug.Print vItem(0), vItem(1)
            
            'find the first occurance in the range
            With rOpDataGroup
                Set rI2 = .Find(What:=vItem(0), _
                                After:=.Cells(1), _
                                LookIn:=xlValues, _
                                LookAt:=xlWhole, _
                                SearchOrder:=xlByRows, _
                                SearchDirection:=xlNext, _
                                MatchCase:=False)
            End With
            'copy to Results2
            rI2.Resize(, 3).Copy rResult2.Offset(iOutputrow2, 6)
            rResult2.Offset(iOutputrow2, 7) = vItem(1)
            iOutputrow2 = iOutputrow2 + 1
            
        Next vItem
        
    Next
    ActiveSheet.Range("A1").Select

    
    
    'cleanup
    On Error Resume Next
    Application.DisplayAlerts = False
    ActiveWorkbook.Sheets("Data-tmp").Delete
    Application.DisplayAlerts = True
    
    
    On Error GoTo 0



End Sub


Function GetUniqueValues(InputRange As Range) As Collection
    Dim cl As Range, UniqueValues As New Collection
    Dim iTmp As Integer, sKey As String, objArr(1) As Variant
    Application.Volatile
    
    On Error Resume Next ' ignore any errors
    For Each cl In InputRange.Cells
        sKey = CStr(cl.Value)
        objArr(0) = sKey: objArr(1) = 1
 
        UniqueValues.Add objArr, sKey ' add the unique item
        If Err.Number > 0 Then
            'failed to add new item so must exist
            iTmp = UniqueValues.Item(sKey)(1)
            'remove and readd with increased count
            UniqueValues.Remove (sKey)
            objArr(0) = sKey: objArr(1) = iTmp + 1
            UniqueValues.Add objArr, sKey
            Err.Clear
        End If
    Next cl
    On Error GoTo 0
    
    Set GetUniqueValues = UniqueValues
    
End Function

Open in new window

Example-Cpmpare-2.xls

tnilesh2

ASKER

Dear Robber Baron,
Great !!!,
I have checked the file, the "result 1" is matching exactly as we want, but in "result 2" small correction is required as some dates are showing wrong (refer attached file).

Also when I ran the macro at my pc (having MS office 2003) then it is showing same Compile Error (refer attached snap), when I ran this macro on some other PC having MS office 2007 then it is working fine. Please suggest how to tackle this problem.

Thanks once again,

Regards,
Nilesh.

Example-Cpmpare-2-Solution.xls
untitled.bmp

ASKER CERTIFIED SOLUTION

Robberbaron (robr)

membership

This solution is only available to members.

To access this solution, you must be a member of Experts Exchange.

Start Free Trial

tnilesh2

ASKER

Dear Robber Baron,
Thank you very much, I have checked the solution & it is working fine with following exceptions –

1. The date of last occurrence is not getting sorted descending (can live with it),
2. The macro XL07 is not working in MS office 2003 as well as MS Office 2007.
3. Suggest the sequence in which the macro has to be run I ran the macro in sequence - Macro 1 => MakeResults => XL07.

Requirement is almost done, You are requested to please resolve the above issue.

<Also I found that in macro XL07 End Sub is placed before 'apply & End with so I have changed the code (please suggest if it is wrong).>

Please help,

Regards,
Nilesh.

 Sub XL07()
    Application.CutCopyMode = False
        
    With wsData.Sort
        .SortFields.Clear
        sTmp = "K" & Format(lRowStart + 1, "0") & ":" & "K" & Format(lRowEnd, "0")
        .SortFields.Add key:=Range(sTmp), _
            SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
            
        sTmp = "N" & Format(lRowStart + 1, "0") & ":" & "N" & Format(lRowEnd, "0")
        .SortFields.Add key:=Range(sTmp), _
            SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
            
        sTmp = "I" & Format(lRowStart, "0") & ":" & "N" & Format(lRowEnd, "0")
        .SetRange Range(sTmp)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
     
   

        .Apply
    End With

 End Sub

Open in new window

Error-424.JPG
Example-Cpmpare-4.xls

Robberbaron (robr)

sorry must have missed your post.

1/ Date of last occurrence is the last one of the workcentre.

2/ The XL07 macro should be deleted as it only works in XL07 ! its a hold over from version2