Edit and correct the code

RAJESH1960

RAJESH1960

Banned for repeated rules violations
Joined
Mar 26, 2020
Messages
2,313
Office Version
  1. 2019
Platform
  1. Windows
JohnnyL,
I have tested more than 50 different data and all the data worked and got the mismatches perfectly. Please run the code in this workbook and check why this data is not shifting the matched and mismatched data to the respective sheets. This is the only data where this application is not working.
I noticed that there are some 0 values in columns G, H and I maybe due to which the issue. After speaking and understanding from an expert, I learnt that there may or may not be 0 value invoices in some cases which are not required to match. Also there are invoices where Supply Attract Reverse Charge and they are mentioned as Yes, in the 2B sheet. These too are not required to match. I have explained briefly in the workbook the changes to be made in the code for the code to work in all kind of data. Please help me to edit and correct the code.
Code to edit.xlsm
 
Sort by date Sort by votes
As I suspected, a rewrite of the 'Match Portal' Module would be required.

The following is the code I have come up with for that module:

VBA Code: 
    Option Explicit

    Dim DestinationLastRow          As Long
    Dim wsDestination               As Worksheet

Sub Match_Portal_Tally()
'updated by JohnnyL as on 15-05-2022

    Application.ScreenUpdating = False                                                                                  ' Turn ScreenUpdating off
'
    Dim DestinationSheetExists      As Boolean, MatchedSheetExists          As Boolean, MismatchesSheetExists   As Boolean
    Dim ArrayColumn                 As Long, ArrayRow                       As Long, DestinationArrayRow        As Long
    Dim LastRow                     As Long
    Dim MatchedRow                  As Long, MismatchesRow                  As Long
    Dim OutputArrayRow              As Long, SourceArrayRow                 As Long
    Dim SheetRow                    As Long
    Dim SourceDataStartRow          As Long, SourceLastRow                  As Long
    Dim Cel                         As Range
    Dim SortRange                   As Range
    Dim DestinationRemarksColumn    As String
    Dim DestinationSheet            As String, MatchedSheet                 As String, MismatchesSheet          As String
    Dim SourceSheet                 As String
    Dim HeaderTitle                 As String
    Dim SourceDataLastWantedColumn  As String, SourceDataStartColumn        As String
    Dim TextDate                    As String
    Dim DataLineNumberArray         As Variant
    Dim DestintionArray             As Variant, OutputArray                 As Variant, SourceArray             As Variant
    Dim HeaderTitlesToPaste         As Variant
    Dim MatchedArray                As Variant, MismatchesArray             As Variant
    Dim wsMatched                   As Worksheet, wsMismatches              As Worksheet
    Dim wsSource                    As Worksheet, wsSubTotal                As Worksheet, ws                    As Worksheet
'
    DestinationSheet = "Combined Data"                                                                                  ' <--- Set this to the name of the sheet to store the shortened Portal data into
         SourceSheet = "PORTAL"                                                                                         ' <--- Set this to the Portal sheet that you want data from
        MatchedSheet = "Matched"                                                                                        ' <--- Set this to the Matched sheet that you copy matches to
     MismatchesSheet = "Mismatches"                                                                                     ' <--- Set this to the Mismatches sheet that you copy mismatches to
'
      DestinationRemarksColumn = "J"                                                                                    ' <--- Set this to the 'Remarks' column letter
    SourceDataLastWantedColumn = "P"                                                                                    ' <--- Set this to the last column of wanted data on the source sheet
         SourceDataStartColumn = "A"                                                                                    ' <--- Set this to the starting column of wanted data on the source sheet
            SourceDataStartRow = 7                                                                                      ' <--- Set this to the starting row of data on the source sheet
'
    Set wsDestination = Nothing
'
    On Error Resume Next                                                                                                ' Bypass error generated in next line if sheet does not exist
    Set wsDestination = Sheets(DestinationSheet)                                                                        ' Assign DestinationSheet to wsDestination
         Set wsSource = Sheets(SourceSheet)                                                                             ' Assign SourceSheet to wsSource
        Set wsMatched = Sheets(MatchedSheet)                                                                            ' Assign MatchedSheet to wsMatched
     Set wsMismatches = Sheets(MismatchesSheet)                                                                         ' Assign MismatchesSheet to wsMismatches
       Set wsSubTotal = Sheets("Sub Total of Matched")                                                                  ' Assign Sheets("Sub Total of Matched") to wsSubTotal
    On Error GoTo 0                                                                                                     ' Turn Excel error handling back on
'
    HeaderTitlesToPaste = Array("Line", "As Per", "GSTIN of supplier", "Trade/Legal name of the Supplier", "Invoice number", _
            "Invoice Date", "Integrated Tax", "Central Tax", "State/UT", "Remarks", "Invoice Value", _
            "Taxable Value", "Filing Date", "Data from")                                                                ' Header row to paste to desired sheets
'
' Create DestinationSheet if it doesn't exist
    If Not wsDestination Is Nothing Then                                                                                ' If wsDestination exists then ...
        DestinationSheetExists = True                                                                                   '   Set DestinationSheetExists flag to True
        wsDestination.UsedRange.Clear                                                                                   '   Delete previous results from destination sheet
        wsDestination.Range("A1:N1").Value = HeaderTitlesToPaste                                                        '   Write header row to DestinationSheet
        wsDestination.Columns("E:F").NumberFormat = "@"                                                                 '   Set columns to text format to prevent excel changing dates
        wsDestination.Range("G:I", "K:L").NumberFormat = "0.00"                                                         '   Set columns to numeric with 2 decimal places
        wsDestination.Columns("M:M").NumberFormat = "@"                                                                 '   Set column to text format to prevent excel changing dates
    Else                                                                                                                ' Else ...
        DestinationSheetExists = False                                                                                  '   Set DestinationSheetExists flag to False
        Sheets.Add(after:=wsSource).Name = DestinationSheet                                                             '   Create the DestinationSheet after the Source sheet
        Set wsDestination = Sheets(DestinationSheet)                                                                    '   Assign the DestinationSheet to wsDestination
'
        wsDestination.Range("A1:N1").Value = HeaderTitlesToPaste                                                        '   Write header row to DestinationSheet
        wsDestination.Columns("E:F").NumberFormat = "@"                                                                 '   Set columns to text format to prevent excel changing dates
        wsDestination.Range("G:I", "K:L").NumberFormat = "0.00"                                                         '   Set columns to numeric with 2 decimal places
        wsDestination.Columns("M:M").NumberFormat = "@"                                                                 '   Set column to text format to prevent excel changing dates
    End If
'
' Create MatchedSheet if it doesn't exist
    If Not wsMatched Is Nothing Then                                                                                    ' If wsMatched exists then ...
        MatchedSheetExists = True                                                                                       '   Set MatchedSheetExists flag to True
        wsMatched.UsedRange.Clear                                                                                       '   Delete previous results from Matches sheet
        wsMatched.Range("A1:N1").Value = HeaderTitlesToPaste                                                            '   Write header row to MatchedSheet
        wsMatched.Columns("E:F").NumberFormat = "@"                                                                     '   Set column to text format to prevent excel changing dates
        wsMatched.Range("G:I", "K:L").NumberFormat = "0.00"                                                             '   Set columns to numeric with 2 decimal places
        wsMatched.Range("M:M").NumberFormat = "dd-mm-yyyy"                                                              '   Format the date the way we want it to appear
    Else                                                                                                                ' Else ...
        MatchedSheetExists = False                                                                                      '   Set MatchedSheetExists flag to False
        Sheets.Add(after:=wsSource).Name = MatchedSheet                                                                 '   Create the MatchedSheet after the Source sheet
        Set wsMatched = Sheets(MatchedSheet)                                                                            '   Assign the MatchedSheet to wsMatched
'
        wsMatched.Range("A1:N1").Value = HeaderTitlesToPaste                                                            '   Write header row to MatchedSheet
        wsMatched.Columns("E:F").NumberFormat = "@"                                                                     '   Set column to text format to prevent excel changing dates
        wsMatched.Range("G:I", "K:L").NumberFormat = "0.00"                                                             '   Set columns to numeric with 2 decimal places
        wsMatched.Range("M:M").NumberFormat = "dd-mm-yyyy"                                                              '   Format the date the way we want it to appear
    End If
'
' Create MismatchesSheet if it doesn't exist
    If Not wsMismatches Is Nothing Then                                                                                 ' If wsMismatches exists then ...
        MismatchesSheetExists = True                                                                                    '   Set MismatchesSheetExists flag to True
        wsMismatches.UsedRange.Clear                                                                                    '   Delete previous results from Mismatches sheet
        wsMismatches.Range("A1:N1").Value = HeaderTitlesToPaste                                                         '   Write header row to MismatchesSheet
        wsMismatches.Columns("E:F").NumberFormat = "@"                                                                  '   Set column to text format to prevent excel changing dates
        wsMismatches.Range("G:I", "K:L").NumberFormat = "0.00"                                                          '   Set columns to numeric with 2 decimal places
        wsMismatches.Range("M:M").NumberFormat = "dd-mm-yyyy"                                                           '   Format the date the way we want it to appear
    Else                                                                                                                ' Else ...
        MismatchesSheetExists = False                                                                                   '   Set MismatchesSheetExists flag to False
        Sheets.Add(after:=wsSource).Name = MismatchesSheet                                                              '   Create the MismatchesSheet after the Source sheet
        Set wsMismatches = Sheets(MismatchesSheet)                                                                      '   Assign the MismatchesSheet to wsMismatches
'
        wsMismatches.Range("A1:N1").Value = HeaderTitlesToPaste                                                         '   Write header row to MismatchesSheet
        wsMismatches.Columns("E:F").NumberFormat = "@"                                                                  '   Set column to text format to prevent excel changing dates
        wsMismatches.Range("G:I", "K:L").NumberFormat = "0.00"                                                          '   Set columns to numeric with 2 decimal places
        wsMismatches.Range("M:M").NumberFormat = "dd-mm-yyyy"                                                           '   Format the date the way we want it to appear
    End If
'
' Delete wsSubTotal if it exist
    If Not wsSubTotal Is Nothing Then                                                                                   ' If wsSubTotal exists then ...
        Application.DisplayAlerts = False                                                                               '   Turn DisplayAlerts off
        Sheets("Sub Total of Matched").Delete                                                                           '   Delete the sheet
        Application.DisplayAlerts = True                                                                                '   Turn DisplayAlerts back on
    End If
'
'---------------------------------------------------------------
'
    SourceLastRow = wsSource.Range("A" & Rows.Count).End(xlUp).Row                                                      ' Get last row used in column A of the source sheeet
'
    SourceArray = wsSource.Range(SourceDataStartColumn & SourceDataStartRow & _
            ":" & SourceDataLastWantedColumn & SourceLastRow)                                                           ' Load all needed data from source sheet to 2D 1 based SourceArray RC
'
    ReDim OutputArray(1 To UBound(SourceArray, 1), 1 To UBound(SourceArray, 2))                                         ' Establish # of rows/columns in 2D 1 based OutputArray
    OutputArrayRow = 0                                                                                                  ' Initialize OutputArrayRow
'
    For SourceArrayRow = 1 To UBound(SourceArray, 1)                                                                    ' Loop through all rows of SourceArray
        If Right$(Application.Trim(SourceArray(SourceArrayRow, 3)), 6) = "-Total" Then                                  '   If a total cell is found in the array then ...(3 represents column C)
            OutputArrayRow = OutputArrayRow + 1                                                                         '       Increment OutputArrayRow
'
            OutputArray(OutputArrayRow, 1) = OutputArrayRow                                                             '       Row #
            OutputArray(OutputArrayRow, 2) = "PORTAL"                                                                   '       'PORTAL'
            OutputArray(OutputArrayRow, 3) = SourceArray(SourceArrayRow, 1)                                             '       GSTIN
            OutputArray(OutputArrayRow, 4) = SourceArray(SourceArrayRow, 2)                                             '       Name of supplier
            OutputArray(OutputArrayRow, 5) = Replace(SourceArray(SourceArrayRow, 3), "-Total", "")                      '       Invoice #
            OutputArray(OutputArrayRow, 6) = SourceArray(SourceArrayRow, 5)                                             '       Invoice Date
            OutputArray(OutputArrayRow, 7) = SourceArray(SourceArrayRow, 11)                                            '       Integrated Tax
            OutputArray(OutputArrayRow, 8) = SourceArray(SourceArrayRow, 12)                                            '       Central Tax
            OutputArray(OutputArrayRow, 9) = SourceArray(SourceArrayRow, 13)                                            '       State/UT Tax
'
            OutputArray(OutputArrayRow, 11) = SourceArray(SourceArrayRow, 6)                                            '       Invoice value
            OutputArray(OutputArrayRow, 12) = SourceArray(SourceArrayRow, 10)                                           '       Taxable value
            OutputArray(OutputArrayRow, 13) = SourceArray(SourceArrayRow, 16)                                           '       Filing Date
            OutputArray(OutputArrayRow, 14) = "As Per Portal"                                                           '       'As Per Portal'
        End If
    Next
'
'---------------------------------------------------------------
'
    With wsDestination
'
        .Range("A2").Resize(UBound(OutputArray, 1), UBound(OutputArray, 2)) = OutputArray                               '   Display results to DestinationSheet
'
        DestinationLastRow = .Range("A" & .Rows.Count).End(xlUp).Row                                                    '   Get last row used in column A of the destination sheeet
'
        .Range("B2:N" & DestinationLastRow).Interior.Color = RGB(146, 208, 80)                                          '   Highlight the range green
        .Range("B2:N" & DestinationLastRow).Font.Bold = True                                                            '   Make the range Bold
'
        For SheetRow = 2 To DestinationLastRow                                                                          '   Loop through rows of the destination sheet
            .Range("F" & SheetRow).Value = .Range("F" & SheetRow).Text                                                  '       Write the TextDate to the cell
            .Range("M" & SheetRow).Value2 = DateValue(.Range("M" & SheetRow))                                           '       Write the Serial Date to the cell
        Next                                                                                                            '   Loop back
'
        .Range("M:M").NumberFormat = "dd-mm-yyyy"                                                                       '   Format the date the way we want it to appear
    End With
'
'---------------------------------------------------------------
'
    For Each ws In Worksheets                                                                                           ' Loop through all worksheets in the workbook
        Select Case ws.Name
            Case Is = SourceSheet, DestinationSheet, "Conditions", "2B", "Matched", "Mismatches"                        '       List of sheets to exclude
'               Skip these sheets
            Case Else                                                                                                   '       All other sheets ...
                Call GetDataFromDataSheet(ws.Name)                                                                      '           Pass sheet name to the sub routine
        End Select
    Next                                                                                                                ' Loop back
'
'---------------------------------------------------------------
'
    DestinationLastRow = wsDestination.Range("A" & wsDestination.Rows.Count).End(xlUp).Row                              ' Get last row used in column A of the destination sheeet
'
    With wsDestination
        .UsedRange.EntireColumn.AutoFit                                                                                 '   Autofit all of the columns on the destination Sheet
        .Columns("G:I").Replace What:="0", Replacement:="", Lookat:=xlWhole, _
            searchorder:=xlByColumns, MatchCase:=False, SearchFormat:=False, _
            ReplaceFormat:=False
'
        .Columns("F:F").HorizontalAlignment = xlCenterAcrossSelection                                                   '   Center the entries in Column F of the destination sheet
'
        For SheetRow = 2 To DestinationLastRow                                                                          '   Loop through rows of the destination sheet
            TextDate = .Range("F" & SheetRow).Text                                                                      '       Save the displayed date as text
            .Range("F" & SheetRow).NumberFormat = "@"                                                                   '       Set the format of the cell to text
            .Range("F" & SheetRow).Value = TextDate                                                                     '       Write the TextDate to the cell
        Next                                                                                                            '   Loop back
    End With
'
 MsgBox "Data extracted successfully. Check Mismatched sheet for more Matches."                                         ' Display message to user
'
'---------------------------------------------------------------------------------------------------
'---------------------------------------------------------------------------------------------------
'---------------------------------------------------------------------------------------------------
'
    With wsSource
        LastRow = .Range(SourceDataStartColumn & .Rows.Count).End(xlUp).Row                                             '   Get last used row of 'Portal'
'
        With .Range(SourceDataStartColumn & SourceDataStartRow & ":" & SourceDataLastWantedColumn & LastRow)
'
            DataLineNumberArray = Filter(.Parent.Evaluate("transpose(if((" & .Columns(8).Address & "=""Yes"")+(" & _
                    .Columns(8).Address & "=""Y""),row(1:" & .Rows.Count & "),char(2)))"), Chr(2), 0)                   '       Save Data line #s to 1D zero based DataLineNumberArray ... Two filter criteria
        End With
    End With
'
    DestintionArray = wsDestination.Range("A2:" & SourceDataLastWantedColumn & DestinationLastRow)                      ' Load all needed data from destination sheet to 2D 1 based DestintionArray RC
'
    For ArrayRow = 0 To UBound(DataLineNumberArray)                                                                     ' Loop through DataLineNumberArray rows
        For DestinationArrayRow = 1 To UBound(DestintionArray, 1)                                                       '   Loop through DestintionArray rows
            If DestintionArray(DestinationArrayRow, 1) = CLng(DataLineNumberArray(ArrayRow)) Then                       '       If a line number was matched to DataLineNumberArray then ...
                wsDestination.Range("J" & DestinationArrayRow + 1) = "Reverse Charge Invoices"                          '           Set the 'Remarks cell to "Reverse Charge Invoices'
            End If
        Next                                                                                                            '   Loop back
    Next                                                                                                                ' Loop back
'
'-------------------------------------------------------------------------------------------------------------------------------
'
    With wsSource
        With .Range(SourceDataStartColumn & SourceDataStartRow & ":" & SourceDataLastWantedColumn & LastRow)
'
            DataLineNumberArray = Filter(.Parent.Evaluate("transpose(if((" & .Columns(9).Address & "=0),row(1:" & _
                    .Rows.Count & "),char(2)))"), Chr(2), 0)                                                            '       Save Data line #s to 1D zero based DataLineNumberArray ...
'                                                                                                                       '               One filter criteria, Column I = 0
        End With
    End With
'
    For ArrayRow = 0 To UBound(DataLineNumberArray)                                                                     ' Loop through DataLineNumberArray rows
        For DestinationArrayRow = 1 To UBound(DestintionArray, 1)                                                       '   Loop through DestintionArray rows
            If DestintionArray(DestinationArrayRow, 1) = CLng(DataLineNumberArray(ArrayRow)) Then                       '       If a line number was matched to DataLineNumberArray then ...
                wsDestination.Range("J" & DestinationArrayRow + 1) = "Exempted Invoices"                          '           Set the 'Remarks cell to "Exempted Invoices'
            End If
        Next                                                                                                            '   Loop back
    Next                                                                                                                ' Loop back
'
'-------------------------------------------------------------------------------------------------------------------------------
'-------------------------------------------------------------------------------------------------------------------------------
'-------------------------------------------------------------------------------------------------------------------------------
'
    With wsDestination
        .Range("A2:N" & .Range("A" & .Rows.Count).End(xlUp).Row).Sort Key1:=.Range(DestinationRemarksColumn & "2"), _
                Order1:=xlDescending, Header:=xlNo                                                                      '   Sort Remarks Column highest to lowest
'
        LastRow = .Columns(10).Find(What:="*", Lookat:=xlPart, LookIn:=xlFormulas, searchorder:=xlByRows, _
                searchdirection:=xlPrevious).Row                                                                        '   Get last used row of Column J in wsDestination
'
        If LastRow > 1 Then                                                                                             '   If we got any results then ...
            .Range("A2:N" & LastRow).Cut wsMismatches.Range("A2")                                                       '       Cut Results thus far & paste to beginning of wsMismatches
            .Rows("2:" & LastRow).Delete                                                                                '       Delete the rows that were cut from wsDestination
        End If
'
'-----------------------------------------------------------------------------------------------------------------------
'
        LastRow = .Range("A" & .Rows.Count).End(xlUp).Row                                                               '   Get last used row of Column A in wsDestination
'
' =IF(COUNTIFS($B$2:$B$20000,IF($B2="PORTAL","TALLY","PORTAL"),$C$2:$C$20000,$C2,$E$2:$E$20000,$E2,$F$2:$F$20000,$F2,$G$2:$G$20000,$G2&"",$H$2:$H$20000,$H2&"",$I$2:$I$20000,$I2&"")>0,"MATCHED","")

        .Range(DestinationRemarksColumn & "2").Formula = "=IF(COUNTIFS($B$2:$B$" & LastRow & ",IF($B2=""PORTAL""," & _
                """TALLY"",""PORTAL""),$C$2:$C$" & LastRow & ",$C2,$E$2:$E$" & LastRow & ",$E2,$F$2:$F$" & _
                LastRow & ",$F2,$G$2:$G$" & LastRow & ",$G2&"""",$H$2:$H$" & LastRow & ",$H2&"""",$I$2:$I$" & LastRow & _
                ",$I2&"""")>0,""MATCHED"","""")"                                                                        '   Formula to put in DestinationRemarksColumn
'
        .Range(DestinationRemarksColumn & "2:" & DestinationRemarksColumn & LastRow).Formula = _
                .Range(DestinationRemarksColumn & "2").Formula                                                          '   Copy the formula down the range without copying the formatting
'
        .Range(DestinationRemarksColumn & "2:" & DestinationRemarksColumn & LastRow).Copy                               '   Copy formula range into memory (Clipboard)
        .Range(DestinationRemarksColumn & "2:" & DestinationRemarksColumn & LastRow).PasteSpecial xlPasteValues         '   Paste just the values back to range
''        Application.CutCopyMode = False                                                                                 '   Clear clipboard & 'marching ants' around copied range
'
        .Range("A2:N" & LastRow).Sort Key1:=.Range(DestinationRemarksColumn & "2"), Order1:=xlDescending, Header:=xlNo  '   Sort Remarks Column highest to lowest
        LastRow = .Columns(10).Find(What:="*", Lookat:=xlPart, LookIn:=xlFormulas, searchorder:=xlByRows, _
                searchdirection:=xlPrevious).Row                                                                        '   Get last used row of Column J in wsDestination
'
        If LastRow > 1 Then                                                                                             '   If we got any results then ...
            .Range("A2:N" & LastRow).Cut wsMatched.Range("A2")                                                          '       Cut Results thus far & paste to beginning of wsMatched
            .Rows("2:" & LastRow).Delete                                                                                '       Delete the rows that were cut from wsDestination
        End If
'
'-----------------------------------------------------------------------------------------------------------------------
'
        LastRow = .Range("A" & .Rows.Count).End(xlUp).Row                                                               '   Get last used row of Column A in wsDestination
'
' =IF(COUNTIFS($B$2:$B$20000,IF($B2="PORTAL","TALLY","PORTAL"),$C$2:$C$20000,$C2,$E$2:$E$20000,$E2,$G$2:$G$20000,$G2&"",$H$2:$H$20000,$H2&"",$I$2:$I$20000,$I2&"")>0,"MATCHED","")
        .Range(DestinationRemarksColumn & "2").Formula = "=IF(COUNTIFS($B$2:$B$" & LastRow & ",IF($B2=""PORTAL""," & _
                """TALLY"",""PORTAL""),$C$2:$C$" & LastRow & ",$C2,$E$2:$E$" & LastRow & ",$E2,$G$2:$G$" & LastRow & _
                ",$G2&"""",$H$2:$H$" & LastRow & ",$H2&"""",$I$2:$I$" & LastRow & ",$I2&"""")>0,""MATCHED"","""")"      '   Formula to put in DestinationRemarksColumn
'
        .Range(DestinationRemarksColumn & "2:" & DestinationRemarksColumn & LastRow).Formula = _
                .Range(DestinationRemarksColumn & "2").Formula                                                          '   Copy the formula down the range without copying the formatting
'
        .Range(DestinationRemarksColumn & "2:" & DestinationRemarksColumn & LastRow).Copy                               '   Copy formula range into memory (Clipboard)
        .Range(DestinationRemarksColumn & "2:" & DestinationRemarksColumn & LastRow).PasteSpecial xlPasteValues         '   Paste just the values back to range
        Application.CutCopyMode = False                                                                                 '   Clear clipboard & 'marching ants' around copied range
'
        .Range("A2:N" & LastRow).Sort Key1:=.Range(DestinationRemarksColumn & "2"), Order1:=xlDescending, Header:=xlNo  '   Sort Remarks Column highest to lowest
        LastRow = .Columns(10).Find(What:="*", Lookat:=xlPart, LookIn:=xlFormulas, searchorder:=xlByRows, _
                searchdirection:=xlPrevious).Row                                                                        '   Get last used row of Column J in wsDestination
'
        If LastRow > 1 Then                                                                                             '   If we got any results then ...
            .Range("A2:N" & LastRow).Cut wsMatched.Range("A" & wsMatched.Range("A" & _
                    wsMatched.Rows.Count).End(xlUp).Row + 1)                                                            '       Cut Results thus far & paste to end of wsMatched
            .Rows("2:" & LastRow).Delete                                                                                '       Delete the rows that were cut from wsDestination
        End If
'
'-----------------------------------------------------------------------------------------------------------------------
'
        LastRow = .Range("A" & .Rows.Count).End(xlUp).Row                                                               '   Get last used row of Column A in wsDestination
'
' =IF(COUNTIFS($B$2:$B$20000,IF($B2="PORTAL","TALLY","PORTAL"),$C$2:$C$20000,$C2,$G$2:$G$20000,$G2&"",$H$2:$H$20000,$H2&"",$I$2:$I$20000,$I2&"")>0,"MATCHED","")
        .Range(DestinationRemarksColumn & "2").Formula = "=IF(COUNTIFS($B$2:$B$" & LastRow & ",IF($B2=""PORTAL""," & _
                """TALLY"",""PORTAL""),$C$2:$C$" & LastRow & ",$C2,$G$2:$G$" & LastRow & _
                ",$G2&"""",$H$2:$H$" & LastRow & ",$H2&"""",$I$2:$I$" & LastRow & ",$I2&"""")>0,""MATCHED"","""")"      '   Formula to put in DestinationRemarksColumn
'
        .Range(DestinationRemarksColumn & "2:" & DestinationRemarksColumn & LastRow).Formula = _
                .Range(DestinationRemarksColumn & "2").Formula                                                          '   Copy the formula down the range without copying the formatting
'
        .Range(DestinationRemarksColumn & "2:" & DestinationRemarksColumn & LastRow).Copy                               '   Copy formula range into memory (Clipboard)
        .Range(DestinationRemarksColumn & "2:" & DestinationRemarksColumn & LastRow).PasteSpecial xlPasteValues         '   Paste just the values back to range
        Application.CutCopyMode = False                                                                                 '   Clear clipboard & 'marching ants' around copied range
'
        .Range("A2:N" & LastRow).Sort Key1:=.Range(DestinationRemarksColumn & "2"), Order1:=xlDescending, Header:=xlNo  '   Sort Remarks Column highest to lowest
        LastRow = .Columns(10).Find(What:="*", Lookat:=xlPart, LookIn:=xlFormulas, searchorder:=xlByRows, _
                searchdirection:=xlPrevious).Row                                                                        '   Get last used row of Column J in wsDestination
'
        If LastRow > 1 Then                                                                                             '   If we got any results then ...
            .Range("A2:N" & LastRow).Cut wsMatched.Range("A" & wsMatched.Range("A" & _
                    wsMatched.Rows.Count).End(xlUp).Row + 1)                                                            '       Cut Results thus far & paste to end of wsMatched
            .Rows("2:" & LastRow).Delete                                                                                '       Delete the rows that were cut from wsDestination
        End If
'
'-----------------------------------------------------------------------------------------------------------------------
'
' This formula is a duplicate formula from above !!! ;)
'
        LastRow = .Range("A" & .Rows.Count).End(xlUp).Row                                                               '   Get last used row of Column A in wsDestination
'
' =IF(COUNTIFS($B$2:$B$20000,IF($B2="PORTAL","TALLY","PORTAL"),$C$2:$C$20000,$C2,$E$2:$E$20000,$E2,$G$2:$G$20000,$G2&"",$H$2:$H$20000,$H2&"",$I$2:$I$20000,$I2&"")>0,"MATCHED","")
        .Range(DestinationRemarksColumn & "2").Formula = "=IF(COUNTIFS($B$2:$B$" & LastRow & ",IF($B2=""PORTAL""," & _
                """TALLY"",""PORTAL""),$C$2:$C$" & LastRow & ",$C2,$E$2:$E$" & LastRow & ",$E2,$G$2:$G$" & LastRow & _
                ",$G2&"""",$H$2:$H$" & LastRow & ",$H2&"""",$I$2:$I$" & LastRow & ",$I2&"""")>0,""MATCHED"","""")"      '   Formula to put in DestinationRemarksColumn
'
        .Range(DestinationRemarksColumn & "2:" & DestinationRemarksColumn & LastRow).Formula = _
                .Range(DestinationRemarksColumn & "2").Formula                                                          '   Copy the formula down the range without copying the formatting
'
        .Range(DestinationRemarksColumn & "2:" & DestinationRemarksColumn & LastRow).Copy                               '   Copy formula range into memory (Clipboard)
        .Range(DestinationRemarksColumn & "2:" & DestinationRemarksColumn & LastRow).PasteSpecial xlPasteValues         '   Paste just the values back to range
        Application.CutCopyMode = False                                                                                 '   Clear clipboard & 'marching ants' around copied range
'
        .Range("A2:N" & LastRow).Sort Key1:=.Range(DestinationRemarksColumn & "2"), Order1:=xlDescending, Header:=xlNo  '   Sort Remarks Column highest to lowest
        LastRow = .Columns(10).Find(What:="*", Lookat:=xlPart, LookIn:=xlFormulas, searchorder:=xlByRows, _
                searchdirection:=xlPrevious).Row                                                                        '   Get last used row of Column J in wsDestination
'
        If LastRow > 1 Then                                                                                             '   If we got any results then ...
            .Range("A2:N" & LastRow).Cut wsMatched.Range("A" & wsMatched.Range("A" & _
                    wsMatched.Rows.Count).End(xlUp).Row + 1)                                                            '       Cut Results thus far & paste to end of wsMatched
            .Rows("2:" & LastRow).Delete                                                                                '       Delete the rows that were cut from wsDestination
        End If
'
'-----------------------------------------------------------------------------------------------------------------------
'
        LastRow = .Range("A" & .Rows.Count).End(xlUp).Row                                                               '   Get last used row of Column A in wsDestination
'
' =IF(IF($G2<>"",COUNTIFS($B:$B,IF($B2="PORTAL","TALLY","PORTAL"),$C:$C,$C2,$E:$E,$E2,$F:$F,$F2,$G:$G,">="&($G2-1),$G:$G,"<="&($G2+1)),COUNTIFS($B:$B,IF($B2="PORTAL","TALLY","PORTAL"),$C:$C,$C2,$E:$E,$E2,$F:$F,$F2,$H:$H,">="&($H2-1),$H:$H,"<="&($H2+1),$I:$I,">="&($I2-1),$I:$I,"<="&($I2+1)))>0,"MATCHED","")
        .Range(DestinationRemarksColumn & "2").Formula = "=IF(IF($G2<>"""",COUNTIFS($B:$B,IF($B2=""PORTAL"",""TALLY""," & _
                """PORTAL""),$C:$C,$C2,$E:$E,$E2,$F:$F,$F2,$G:$G,"">=""&($G2-1),$G:$G,""<=""&($G2+1)),COUNTIFS($B:$B," & _
                "IF($B2=""PORTAL"",""TALLY"",""PORTAL""),$C:$C,$C2,$E:$E,$E2,$F:$F,$F2,$H:$H,"">=""&($H2-1)," & _
                "$H:$H,""<=""&($H2+1),$I:$I,"">=""&($I2-1),$I:$I,""<=""&($I2+1)))>0,""MATCHED"","""")"                  '   Formula to put in DestinationRemarksColumn
'
        .Range(DestinationRemarksColumn & "2:" & DestinationRemarksColumn & LastRow).Formula = _
                .Range(DestinationRemarksColumn & "2").Formula                                                          '   Copy the formula down the range without copying the formatting
'
        .Range(DestinationRemarksColumn & "2:" & DestinationRemarksColumn & LastRow).Copy                               '   Copy formula range into memory (Clipboard)
        .Range(DestinationRemarksColumn & "2:" & DestinationRemarksColumn & LastRow).PasteSpecial xlPasteValues         '   Paste just the values back to range
        Application.CutCopyMode = False                                                                                 '   Clear clipboard & 'marching ants' around copied range
'
        .Range("A2:N" & LastRow).Sort Key1:=.Range(DestinationRemarksColumn & "2"), Order1:=xlDescending, Header:=xlNo  '   Sort Remarks Column highest to lowest
        LastRow = .Columns(10).Find(What:="*", Lookat:=xlPart, LookIn:=xlFormulas, searchorder:=xlByRows, _
                searchdirection:=xlPrevious).Row                                                                        '   Get last used row of Column J in wsDestination
'
        If LastRow > 1 Then                                                                                             '   If we got any results then ...
            .Range("A2:N" & LastRow).Cut wsMatched.Range("A" & wsMatched.Range("A" & _
                    wsMatched.Rows.Count).End(xlUp).Row + 1)                                                            '       Cut Results thus far & paste to end of wsMatched
            .Rows("2:" & LastRow).Delete                                                                                '       Delete the rows that were cut from wsDestination
        End If
'
'-----------------------------------------------------------------------------------------------------------------------
'
' Something wrong with this formula ??? It doesn't paste as a formula
'
        LastRow = .Range("A" & .Rows.Count).End(xlUp).Row                                                               '   Get last used row of Column A in wsDestination
'
' =IF(IF($G2<>"",COUNTIFS($B:$B,IF($B2="PORTAL","TALLY","PORTAL"),$C:$C,$C2,$E:$E,$E2,$G:$G,">="&($G2-1),$G:$G,"<="&($G2+1)),COUNTIFS($B:$B,IF($B2="PORTAL","TALLY","PORTAL"),$C:$C,$C2,$E:$E,$E2,$H:$H,">="&($H2-1),$H:$H,"<="&($H2+1),$I:$I,">="&($I2-1),$I:$I,"<="&($I2+1)))>0,"MATCHED","")
        .Range(DestinationRemarksColumn & "2").Formula = "=IF(IF($G2<>"""",COUNTIFS($B:$B,IF($B2=""PORTAL"",""TALLY""," & _
                """PORTAL""),$C:$C,$C2,$E:$E,$E2,$G:$G,"">=""&($G2-1),$G:$G,""<=""&($G2+1)),COUNTIFS($B:$B," & _
                "IF($B2=""PORTAL"",""TALLY"",""PORTAL""),$C:$C,$C2,$E:$E,$E2,$H:$H,"">=""&($H2-1),$H:$H,""<=""&" & _
                "($H2+1),$I:$I,"">=""&($I2-1),$I:$I,""<=""&($I2+1)))>0,""MATCHED"","""")"                               '   Formula to put in DestinationRemarksColumn
'
        .Range(DestinationRemarksColumn & "2:" & DestinationRemarksColumn & LastRow).Formula = _
                .Range(DestinationRemarksColumn & "2").Formula                                                          '   Copy the formula down the range without copying the formatting
'
        .Range(DestinationRemarksColumn & "2:" & DestinationRemarksColumn & LastRow).Copy                               '   Copy formula range into memory (Clipboard)
        .Range(DestinationRemarksColumn & "2:" & DestinationRemarksColumn & LastRow).PasteSpecial xlPasteValues         '   Paste just the values back to range
        Application.CutCopyMode = False                                                                                 '   Clear clipboard & 'marching ants' around copied range
'
        .Range("A2:N" & LastRow).Sort Key1:=.Range(DestinationRemarksColumn & "2"), Order1:=xlDescending, Header:=xlNo  '   Sort Remarks Column highest to lowest
        LastRow = .Columns(10).Find(What:="*", Lookat:=xlPart, LookIn:=xlFormulas, searchorder:=xlByRows, _
                searchdirection:=xlPrevious).Row                                                                        '   Get last used row of Column J in wsDestination
'
        If LastRow > 1 Then                                                                                             '   If we got any results then ...
            .Range("A2:N" & LastRow).Cut wsMatched.Range("A" & wsMatched.Range("A" & _
                    wsMatched.Rows.Count).End(xlUp).Row + 1)                                                            '       Cut Results thus far & paste to end of wsMatched
            .Rows("2:" & LastRow).Delete                                                                                '       Delete the rows that were cut from wsDestination
        End If
'
'-----------------------------------------------------------------------------------------------------------------------
'
        LastRow = .Range("A" & .Rows.Count).End(xlUp).Row                                                               '   Get last used row of Column A in wsDestination
'
' =IF(COUNTIFS($B:$B,IF($B2="PORTAL","TALLY","PORTAL"),IF($G2<>"",$G:$G,$H:$H),">="&(IF($G2<>"",$G2,$H2)-1),IF($G2<>"",$G:$G,$H:$H),"<="&(IF($G2<>"",$G2,$H2)+1))>0,"MATCHED","Not Found")
        .Range(DestinationRemarksColumn & "2").Formula = "=IF(COUNTIFS($B:$B,IF($B2=""PORTAL"",""TALLY"",""PORTAL"")" & _
                ",IF($G2<>"""",$G:$G,$H:$H),"">=""&(IF($G2<>"""",$G2,$H2)-1),IF($G2<>"""",$G:$G,$H:$H),""<=""&" & _
                "(IF($G2<>"""",$G2,$H2)+1))>0,""MATCHED"","""")"                                                        '   Formula to put in DestinationRemarksColumn
'
        .Range(DestinationRemarksColumn & "2:" & DestinationRemarksColumn & LastRow).Formula = _
                .Range(DestinationRemarksColumn & "2").Formula                                                          '   Copy the formula down the range without copying the formatting
'
        .Range(DestinationRemarksColumn & "2:" & DestinationRemarksColumn & LastRow).Copy                               '   Copy formula range into memory (Clipboard)
        .Range(DestinationRemarksColumn & "2:" & DestinationRemarksColumn & LastRow).PasteSpecial xlPasteValues         '   Paste just the values back to range
        Application.CutCopyMode = False                                                                                 '   Clear clipboard & 'marching ants' around copied range
'
        .Range("A2:N" & LastRow).Sort Key1:=.Range(DestinationRemarksColumn & "2"), Order1:=xlDescending, Header:=xlNo  '   Sort Remarks Column highest to lowest
        LastRow = .Columns(10).Find(What:="*", Lookat:=xlPart, LookIn:=xlFormulas, searchorder:=xlByRows, _
                searchdirection:=xlPrevious).Row                                                                        '   Get last used row of Column J in wsDestination
'
        If LastRow > 1 Then                                                                                             '   If we got any results then ...
            .Range("A2:N" & LastRow).Cut wsMatched.Range("A" & wsMatched.Range("A" & _
                    wsMatched.Rows.Count).End(xlUp).Row + 1)                                                            '       Cut Results thus far & paste to end of wsMatched
            .Rows("2:" & LastRow).Delete                                                                                '       Delete the rows that were cut from wsDestination
        End If
'
'-----------------------------------------------------------------------------------------------------------------------
'
        LastRow = .Range("A" & .Rows.Count).End(xlUp).Row                                                               '   Get last used row of Column A in wsDestination
'
' =IF(COUNTIFS($B:$B,IF($B2="PORTAL","TALLY","PORTAL"),IF($G2<>"",$G:$G,$H:$H),">="&(IF($G2<>"",$G2,$H2)-1),IF($G2<>"",$G:$G,$H:$H),"<="&(IF($G2<>"",$G2,$H2)+1))>0,"MATCHED","Not Found")
        .Range(DestinationRemarksColumn & "2").Formula = "=IF(COUNTIFS($B:$B,IF($B2=""PORTAL"",""TALLY"",""PORTAL"")" & _
                ",IF($G2<>"""",$G:$G,$H:$H),"">=""&(IF($G2<>"""",$G2,$H2)-1),IF($G2<>"""",$G:$G,$H:$H),""<=""&" & _
                "(IF($G2<>"""",$G2,$H2)+1))>0,"""",""Not Found"")"                                                      '   Formula to put in DestinationRemarksColumn
'
        .Range(DestinationRemarksColumn & "2:" & DestinationRemarksColumn & LastRow).Formula = _
                .Range(DestinationRemarksColumn & "2").Formula                                                          '   Copy the formula down the range without copying the formatting
'
        .Range(DestinationRemarksColumn & "2:" & DestinationRemarksColumn & LastRow).Copy                               '   Copy formula range into memory (Clipboard)
        .Range(DestinationRemarksColumn & "2:" & DestinationRemarksColumn & LastRow).PasteSpecial xlPasteValues         '   Paste just the values back to range
        Application.CutCopyMode = False                                                                                 '   Clear clipboard & 'marching ants' around copied range
'
        .Range("A2:N" & LastRow).Sort Key1:=.Range(DestinationRemarksColumn & "2"), Order1:=xlDescending, Header:=xlNo  '   Sort Remarks Column highest to lowest
        LastRow = .Columns(10).Find(What:="*", Lookat:=xlPart, LookIn:=xlFormulas, searchorder:=xlByRows, _
                searchdirection:=xlPrevious).Row                                                                        '   Get last used row of Column J in wsDestination
'
        If LastRow > 1 Then                                                                                             '   If we got any results then ...
            .Range("A2:N" & LastRow).Cut wsMismatches.Range("A" & wsMismatches.Range("A" & _
                    wsMismatches.Rows.Count).End(xlUp).Row + 1)                                                         '       Cut Results thus far & paste to end of wsMismatches
            .Rows("2:" & LastRow).Delete                                                                                '       Delete the rows that were cut from wsDestination
        End If
    End With
'
'-----------------------------------------------------------------------------------------------------------------------
'
    Call CheckSubTotal                                                                                                  '
'
    Application.ScreenUpdating = True                                                                                   ' Turn ScreenUpdating back on
'
    If wsMismatches.Range("B2") = "" Then MsgBox "No MisMatches Found"                                                  ' If No MisMatches Found, tell the user
End Sub


Sub GetDataFromDataSheet(DataWorkSheet As String)
'
    Dim ArrayColumn                 As Long, ArrayRow       As Long
    Dim DataLastColumn              As String, DataLastRow  As Long, DestinationStartRow    As Long
    Dim CorrectedDataArray          As Variant
    Dim DataSheetArray              As Variant
'
    With Sheets(DataWorkSheet)
        DataLastRow = .Range("A" & .Rows.Count).End(xlUp).Row                                                           '   Get last row of the Data sheet column B
'
        DataLastColumn = Split(Cells(1, (.Cells.Find("*", _
            , xlFormulas, , xlByColumns, xlPrevious).Column)).Address, "$")(1)                                          '   Get last column letter of the Data sheet
'
        .Columns("E:E").NumberFormat = "General"                                                                        '   Set date column to General format
'
        DataSheetArray = .Range("A2:" & DataLastColumn & DataLastRow)                                                   '   Load Data from Data sheet to 2D 1 based DataSheetArray
'
        .Columns("E:E").NumberFormat = "m/d/yyyy"                                                                       '   Change date column back to standard date
    End With
'
    ReDim CorrectedDataArray(1 To UBound(DataSheetArray, 1), 1 To UBound(DataSheetArray, 2) + 2)                        ' Set the number of rows & columns for the CorrectedDataArray
'
    For ArrayRow = 1 To UBound(DataSheetArray, 1)                                                                       ' Loop through the rows of DataSheetArray
        For ArrayColumn = 1 To UBound(CorrectedDataArray, 2)                                                            '   Loop through the columns of CorrectedDataArray
            Select Case ArrayColumn
                Case 2
                    CorrectedDataArray(ArrayRow, ArrayColumn) = "TALLY"                                                 '       Save DataSheetArray data into CorrectedDataArray

                Case 1, 10:                                                                                             '       Skip these Columns, Leave the column blank
                Case 12:
                    CorrectedDataArray(ArrayRow, ArrayColumn) = DataSheetArray(ArrayRow, ArrayColumn - 3)               '       Save DataSheetArray data into CorrectedDataArray
                Case Else
                    CorrectedDataArray(ArrayRow, ArrayColumn) = DataSheetArray(ArrayRow, ArrayColumn - 1)               '       Save DataSheetArray data into CorrectedDataArray
            End Select
        Next                                                                                                            '   Loop back
    Next                                                                                                                ' Loop back
'
    DestinationStartRow = DestinationLastRow + 1                                                                        ' Save DestinationLastRow + 1 into DestinationStartRow
'
    With wsDestination
        .Range("A" & DestinationStartRow).Resize(UBound(CorrectedDataArray, _
            1), UBound(CorrectedDataArray, 2)) = CorrectedDataArray                                                     '   Display Results to destination sheet
'
        .Range("F:F").NumberFormat = "dd-mm-yyyy"                                                                       '   Format the date the way we want it to appear
'
        .Columns("M:M").TextToColumns Destination:=.Range("M1"), DataType:=xlDelimited, FieldInfo:=Array(1, 4)          '   Convert text to numeric
'
        DestinationLastRow = .Range("B" & .Rows.Count).End(xlUp).Row                                                    '   Recalculate last row used in column B of the destination sheeet
'
        .Range("N" & DestinationStartRow & ":N" & DestinationLastRow) = "As per " & DataWorkSheet                       '   Copy 'As Per ' & sheet name to Column N
'
        .Range("A" & DestinationStartRow & ":A" & DestinationLastRow).Formula = "=Row() - 1"                            '   Use formula to set row #s
        .Range("A" & DestinationStartRow & ":A" & DestinationLastRow).Copy                                              '   Copy formula range into memory (clipboard)
        .Range("A" & DestinationStartRow & ":A" & DestinationLastRow).PasteSpecial xlPasteValues                        '   Paste just the vales back to range
        Application.CutCopyMode = False                                                                                 '   Clear clipboard & 'marching ants' around copied range
    End With
End Sub


A few things I noticed, A few of the formulas need to be looked at.
1) Your 2nd formula and your fourth formula are the same?
2) Some of your formulas do not yield any results, I assume that is because of the limited data sample?
3) Your 2nd to last formula doesn't appear to paste properly.

I have also 'split' your last formula to make it easier to copy the results to the proper sheets.

I think I have touched a lot of bases with this version of code. Let me know which ones I missed after you test the new code.
 
Upvote 0

Excel Facts

Excel Can Read to You
Customize Quick Access Toolbar. From All Commands, add Speak Cells or Speak Cells on Enter to QAT. Select cells. Press Speak Cells.
johnnyL said:
As I suspected, a rewrite of the 'Match Portal' Module would be required.

The following is the code I have come up with for that module:

VBA Code: 
    Option Explicit

    Dim DestinationLastRow          As Long
    Dim wsDestination               As Worksheet

Sub Match_Portal_Tally()
'updated by JohnnyL as on 15-05-2022

    Application.ScreenUpdating = False                                                                                  ' Turn ScreenUpdating off
'
    Dim DestinationSheetExists      As Boolean, MatchedSheetExists          As Boolean, MismatchesSheetExists   As Boolean
    Dim ArrayColumn                 As Long, ArrayRow                       As Long, DestinationArrayRow        As Long
    Dim LastRow                     As Long
    Dim MatchedRow                  As Long, MismatchesRow                  As Long
    Dim OutputArrayRow              As Long, SourceArrayRow                 As Long
    Dim SheetRow                    As Long
    Dim SourceDataStartRow          As Long, SourceLastRow                  As Long
    Dim Cel                         As Range
    Dim SortRange                   As Range
    Dim DestinationRemarksColumn    As String
    Dim DestinationSheet            As String, MatchedSheet                 As String, MismatchesSheet          As String
    Dim SourceSheet                 As String
    Dim HeaderTitle                 As String
    Dim SourceDataLastWantedColumn  As String, SourceDataStartColumn        As String
    Dim TextDate                    As String
    Dim DataLineNumberArray         As Variant
    Dim DestintionArray             As Variant, OutputArray                 As Variant, SourceArray             As Variant
    Dim HeaderTitlesToPaste         As Variant
    Dim MatchedArray                As Variant, MismatchesArray             As Variant
    Dim wsMatched                   As Worksheet, wsMismatches              As Worksheet
    Dim wsSource                    As Worksheet, wsSubTotal                As Worksheet, ws                    As Worksheet
'
    DestinationSheet = "Combined Data"                                                                                  ' <--- Set this to the name of the sheet to store the shortened Portal data into
         SourceSheet = "PORTAL"                                                                                         ' <--- Set this to the Portal sheet that you want data from
        MatchedSheet = "Matched"                                                                                        ' <--- Set this to the Matched sheet that you copy matches to
     MismatchesSheet = "Mismatches"                                                                                     ' <--- Set this to the Mismatches sheet that you copy mismatches to
'
      DestinationRemarksColumn = "J"                                                                                    ' <--- Set this to the 'Remarks' column letter
    SourceDataLastWantedColumn = "P"                                                                                    ' <--- Set this to the last column of wanted data on the source sheet
         SourceDataStartColumn = "A"                                                                                    ' <--- Set this to the starting column of wanted data on the source sheet
            SourceDataStartRow = 7                                                                                      ' <--- Set this to the starting row of data on the source sheet
'
    Set wsDestination = Nothing
'
    On Error Resume Next                                                                                                ' Bypass error generated in next line if sheet does not exist
    Set wsDestination = Sheets(DestinationSheet)                                                                        ' Assign DestinationSheet to wsDestination
         Set wsSource = Sheets(SourceSheet)                                                                             ' Assign SourceSheet to wsSource
        Set wsMatched = Sheets(MatchedSheet)                                                                            ' Assign MatchedSheet to wsMatched
     Set wsMismatches = Sheets(MismatchesSheet)                                                                         ' Assign MismatchesSheet to wsMismatches
       Set wsSubTotal = Sheets("Sub Total of Matched")                                                                  ' Assign Sheets("Sub Total of Matched") to wsSubTotal
    On Error GoTo 0                                                                                                     ' Turn Excel error handling back on
'
    HeaderTitlesToPaste = Array("Line", "As Per", "GSTIN of supplier", "Trade/Legal name of the Supplier", "Invoice number", _
            "Invoice Date", "Integrated Tax", "Central Tax", "State/UT", "Remarks", "Invoice Value", _
            "Taxable Value", "Filing Date", "Data from")                                                                ' Header row to paste to desired sheets
'
' Create DestinationSheet if it doesn't exist
    If Not wsDestination Is Nothing Then                                                                                ' If wsDestination exists then ...
        DestinationSheetExists = True                                                                                   '   Set DestinationSheetExists flag to True
        wsDestination.UsedRange.Clear                                                                                   '   Delete previous results from destination sheet
        wsDestination.Range("A1:N1").Value = HeaderTitlesToPaste                                                        '   Write header row to DestinationSheet
        wsDestination.Columns("E:F").NumberFormat = "@"                                                                 '   Set columns to text format to prevent excel changing dates
        wsDestination.Range("G:I", "K:L").NumberFormat = "0.00"                                                         '   Set columns to numeric with 2 decimal places
        wsDestination.Columns("M:M").NumberFormat = "@"                                                                 '   Set column to text format to prevent excel changing dates
    Else                                                                                                                ' Else ...
        DestinationSheetExists = False                                                                                  '   Set DestinationSheetExists flag to False
        Sheets.Add(after:=wsSource).Name = DestinationSheet                                                             '   Create the DestinationSheet after the Source sheet
        Set wsDestination = Sheets(DestinationSheet)                                                                    '   Assign the DestinationSheet to wsDestination
'
        wsDestination.Range("A1:N1").Value = HeaderTitlesToPaste                                                        '   Write header row to DestinationSheet
        wsDestination.Columns("E:F").NumberFormat = "@"                                                                 '   Set columns to text format to prevent excel changing dates
        wsDestination.Range("G:I", "K:L").NumberFormat = "0.00"                                                         '   Set columns to numeric with 2 decimal places
        wsDestination.Columns("M:M").NumberFormat = "@"                                                                 '   Set column to text format to prevent excel changing dates
    End If
'
' Create MatchedSheet if it doesn't exist
    If Not wsMatched Is Nothing Then                                                                                    ' If wsMatched exists then ...
        MatchedSheetExists = True                                                                                       '   Set MatchedSheetExists flag to True
        wsMatched.UsedRange.Clear                                                                                       '   Delete previous results from Matches sheet
        wsMatched.Range("A1:N1").Value = HeaderTitlesToPaste                                                            '   Write header row to MatchedSheet
        wsMatched.Columns("E:F").NumberFormat = "@"                                                                     '   Set column to text format to prevent excel changing dates
        wsMatched.Range("G:I", "K:L").NumberFormat = "0.00"                                                             '   Set columns to numeric with 2 decimal places
        wsMatched.Range("M:M").NumberFormat = "dd-mm-yyyy"                                                              '   Format the date the way we want it to appear
    Else                                                                                                                ' Else ...
        MatchedSheetExists = False                                                                                      '   Set MatchedSheetExists flag to False
        Sheets.Add(after:=wsSource).Name = MatchedSheet                                                                 '   Create the MatchedSheet after the Source sheet
        Set wsMatched = Sheets(MatchedSheet)                                                                            '   Assign the MatchedSheet to wsMatched
'
        wsMatched.Range("A1:N1").Value = HeaderTitlesToPaste                                                            '   Write header row to MatchedSheet
        wsMatched.Columns("E:F").NumberFormat = "@"                                                                     '   Set column to text format to prevent excel changing dates
        wsMatched.Range("G:I", "K:L").NumberFormat = "0.00"                                                             '   Set columns to numeric with 2 decimal places
        wsMatched.Range("M:M").NumberFormat = "dd-mm-yyyy"                                                              '   Format the date the way we want it to appear
    End If
'
' Create MismatchesSheet if it doesn't exist
    If Not wsMismatches Is Nothing Then                                                                                 ' If wsMismatches exists then ...
        MismatchesSheetExists = True                                                                                    '   Set MismatchesSheetExists flag to True
        wsMismatches.UsedRange.Clear                                                                                    '   Delete previous results from Mismatches sheet
        wsMismatches.Range("A1:N1").Value = HeaderTitlesToPaste                                                         '   Write header row to MismatchesSheet
        wsMismatches.Columns("E:F").NumberFormat = "@"                                                                  '   Set column to text format to prevent excel changing dates
        wsMismatches.Range("G:I", "K:L").NumberFormat = "0.00"                                                          '   Set columns to numeric with 2 decimal places
        wsMismatches.Range("M:M").NumberFormat = "dd-mm-yyyy"                                                           '   Format the date the way we want it to appear
    Else                                                                                                                ' Else ...
        MismatchesSheetExists = False                                                                                   '   Set MismatchesSheetExists flag to False
        Sheets.Add(after:=wsSource).Name = MismatchesSheet                                                              '   Create the MismatchesSheet after the Source sheet
        Set wsMismatches = Sheets(MismatchesSheet)                                                                      '   Assign the MismatchesSheet to wsMismatches
'
        wsMismatches.Range("A1:N1").Value = HeaderTitlesToPaste                                                         '   Write header row to MismatchesSheet
        wsMismatches.Columns("E:F").NumberFormat = "@"                                                                  '   Set column to text format to prevent excel changing dates
        wsMismatches.Range("G:I", "K:L").NumberFormat = "0.00"                                                          '   Set columns to numeric with 2 decimal places
        wsMismatches.Range("M:M").NumberFormat = "dd-mm-yyyy"                                                           '   Format the date the way we want it to appear
    End If
'
' Delete wsSubTotal if it exist
    If Not wsSubTotal Is Nothing Then                                                                                   ' If wsSubTotal exists then ...
        Application.DisplayAlerts = False                                                                               '   Turn DisplayAlerts off
        Sheets("Sub Total of Matched").Delete                                                                           '   Delete the sheet
        Application.DisplayAlerts = True                                                                                '   Turn DisplayAlerts back on
    End If
'
'---------------------------------------------------------------
'
    SourceLastRow = wsSource.Range("A" & Rows.Count).End(xlUp).Row                                                      ' Get last row used in column A of the source sheeet
'
    SourceArray = wsSource.Range(SourceDataStartColumn & SourceDataStartRow & _
            ":" & SourceDataLastWantedColumn & SourceLastRow)                                                           ' Load all needed data from source sheet to 2D 1 based SourceArray RC
'
    ReDim OutputArray(1 To UBound(SourceArray, 1), 1 To UBound(SourceArray, 2))                                         ' Establish # of rows/columns in 2D 1 based OutputArray
    OutputArrayRow = 0                                                                                                  ' Initialize OutputArrayRow
'
    For SourceArrayRow = 1 To UBound(SourceArray, 1)                                                                    ' Loop through all rows of SourceArray
        If Right$(Application.Trim(SourceArray(SourceArrayRow, 3)), 6) = "-Total" Then                                  '   If a total cell is found in the array then ...(3 represents column C)
            OutputArrayRow = OutputArrayRow + 1                                                                         '       Increment OutputArrayRow
'
            OutputArray(OutputArrayRow, 1) = OutputArrayRow                                                             '       Row #
            OutputArray(OutputArrayRow, 2) = "PORTAL"                                                                   '       'PORTAL'
            OutputArray(OutputArrayRow, 3) = SourceArray(SourceArrayRow, 1)                                             '       GSTIN
            OutputArray(OutputArrayRow, 4) = SourceArray(SourceArrayRow, 2)                                             '       Name of supplier
            OutputArray(OutputArrayRow, 5) = Replace(SourceArray(SourceArrayRow, 3), "-Total", "")                      '       Invoice #
            OutputArray(OutputArrayRow, 6) = SourceArray(SourceArrayRow, 5)                                             '       Invoice Date
            OutputArray(OutputArrayRow, 7) = SourceArray(SourceArrayRow, 11)                                            '       Integrated Tax
            OutputArray(OutputArrayRow, 8) = SourceArray(SourceArrayRow, 12)                                            '       Central Tax
            OutputArray(OutputArrayRow, 9) = SourceArray(SourceArrayRow, 13)                                            '       State/UT Tax
'
            OutputArray(OutputArrayRow, 11) = SourceArray(SourceArrayRow, 6)                                            '       Invoice value
            OutputArray(OutputArrayRow, 12) = SourceArray(SourceArrayRow, 10)                                           '       Taxable value
            OutputArray(OutputArrayRow, 13) = SourceArray(SourceArrayRow, 16)                                           '       Filing Date
            OutputArray(OutputArrayRow, 14) = "As Per Portal"                                                           '       'As Per Portal'
        End If
    Next
'
'---------------------------------------------------------------
'
    With wsDestination
'
        .Range("A2").Resize(UBound(OutputArray, 1), UBound(OutputArray, 2)) = OutputArray                               '   Display results to DestinationSheet
'
        DestinationLastRow = .Range("A" & .Rows.Count).End(xlUp).Row                                                    '   Get last row used in column A of the destination sheeet
'
        .Range("B2:N" & DestinationLastRow).Interior.Color = RGB(146, 208, 80)                                          '   Highlight the range green
        .Range("B2:N" & DestinationLastRow).Font.Bold = True                                                            '   Make the range Bold
'
        For SheetRow = 2 To DestinationLastRow                                                                          '   Loop through rows of the destination sheet
            .Range("F" & SheetRow).Value = .Range("F" & SheetRow).Text                                                  '       Write the TextDate to the cell
            .Range("M" & SheetRow).Value2 = DateValue(.Range("M" & SheetRow))                                           '       Write the Serial Date to the cell
        Next                                                                                                            '   Loop back
'
        .Range("M:M").NumberFormat = "dd-mm-yyyy"                                                                       '   Format the date the way we want it to appear
    End With
'
'---------------------------------------------------------------
'
    For Each ws In Worksheets                                                                                           ' Loop through all worksheets in the workbook
        Select Case ws.Name
            Case Is = SourceSheet, DestinationSheet, "Conditions", "2B", "Matched", "Mismatches"                        '       List of sheets to exclude
'               Skip these sheets
            Case Else                                                                                                   '       All other sheets ...
                Call GetDataFromDataSheet(ws.Name)                                                                      '           Pass sheet name to the sub routine
        End Select
    Next                                                                                                                ' Loop back
'
'---------------------------------------------------------------
'
    DestinationLastRow = wsDestination.Range("A" & wsDestination.Rows.Count).End(xlUp).Row                              ' Get last row used in column A of the destination sheeet
'
    With wsDestination
        .UsedRange.EntireColumn.AutoFit                                                                                 '   Autofit all of the columns on the destination Sheet
        .Columns("G:I").Replace What:="0", Replacement:="", Lookat:=xlWhole, _
            searchorder:=xlByColumns, MatchCase:=False, SearchFormat:=False, _
            ReplaceFormat:=False
'
        .Columns("F:F").HorizontalAlignment = xlCenterAcrossSelection                                                   '   Center the entries in Column F of the destination sheet
'
        For SheetRow = 2 To DestinationLastRow                                                                          '   Loop through rows of the destination sheet
            TextDate = .Range("F" & SheetRow).Text                                                                      '       Save the displayed date as text
            .Range("F" & SheetRow).NumberFormat = "@"                                                                   '       Set the format of the cell to text
            .Range("F" & SheetRow).Value = TextDate                                                                     '       Write the TextDate to the cell
        Next                                                                                                            '   Loop back
    End With
'
 MsgBox "Data extracted successfully. Check Mismatched sheet for more Matches."                                         ' Display message to user
'
'---------------------------------------------------------------------------------------------------
'---------------------------------------------------------------------------------------------------
'---------------------------------------------------------------------------------------------------
'
    With wsSource
        LastRow = .Range(SourceDataStartColumn & .Rows.Count).End(xlUp).Row                                             '   Get last used row of 'Portal'
'
        With .Range(SourceDataStartColumn & SourceDataStartRow & ":" & SourceDataLastWantedColumn & LastRow)
'
            DataLineNumberArray = Filter(.Parent.Evaluate("transpose(if((" & .Columns(8).Address & "=""Yes"")+(" & _
                    .Columns(8).Address & "=""Y""),row(1:" & .Rows.Count & "),char(2)))"), Chr(2), 0)                   '       Save Data line #s to 1D zero based DataLineNumberArray ... Two filter criteria
        End With
    End With
'
    DestintionArray = wsDestination.Range("A2:" & SourceDataLastWantedColumn & DestinationLastRow)                      ' Load all needed data from destination sheet to 2D 1 based DestintionArray RC
'
    For ArrayRow = 0 To UBound(DataLineNumberArray)                                                                     ' Loop through DataLineNumberArray rows
        For DestinationArrayRow = 1 To UBound(DestintionArray, 1)                                                       '   Loop through DestintionArray rows
            If DestintionArray(DestinationArrayRow, 1) = CLng(DataLineNumberArray(ArrayRow)) Then                       '       If a line number was matched to DataLineNumberArray then ...
                wsDestination.Range("J" & DestinationArrayRow + 1) = "Reverse Charge Invoices"                          '           Set the 'Remarks cell to "Reverse Charge Invoices'
            End If
        Next                                                                                                            '   Loop back
    Next                                                                                                                ' Loop back
'
'-------------------------------------------------------------------------------------------------------------------------------
'
    With wsSource
        With .Range(SourceDataStartColumn & SourceDataStartRow & ":" & SourceDataLastWantedColumn & LastRow)
'
            DataLineNumberArray = Filter(.Parent.Evaluate("transpose(if((" & .Columns(9).Address & "=0),row(1:" & _
                    .Rows.Count & "),char(2)))"), Chr(2), 0)                                                            '       Save Data line #s to 1D zero based DataLineNumberArray ...
'                                                                                                                       '               One filter criteria, Column I = 0
        End With
    End With
'
    For ArrayRow = 0 To UBound(DataLineNumberArray)                                                                     ' Loop through DataLineNumberArray rows
        For DestinationArrayRow = 1 To UBound(DestintionArray, 1)                                                       '   Loop through DestintionArray rows
            If DestintionArray(DestinationArrayRow, 1) = CLng(DataLineNumberArray(ArrayRow)) Then                       '       If a line number was matched to DataLineNumberArray then ...
                wsDestination.Range("J" & DestinationArrayRow + 1) = "Exempted Invoices"                          '           Set the 'Remarks cell to "Exempted Invoices'
            End If
        Next                                                                                                            '   Loop back
    Next                                                                                                                ' Loop back
'
'-------------------------------------------------------------------------------------------------------------------------------
'-------------------------------------------------------------------------------------------------------------------------------
'-------------------------------------------------------------------------------------------------------------------------------
'
    With wsDestination
        .Range("A2:N" & .Range("A" & .Rows.Count).End(xlUp).Row).Sort Key1:=.Range(DestinationRemarksColumn & "2"), _
                Order1:=xlDescending, Header:=xlNo                                                                      '   Sort Remarks Column highest to lowest
'
        LastRow = .Columns(10).Find(What:="*", Lookat:=xlPart, LookIn:=xlFormulas, searchorder:=xlByRows, _
                searchdirection:=xlPrevious).Row                                                                        '   Get last used row of Column J in wsDestination
'
        If LastRow > 1 Then                                                                                             '   If we got any results then ...
            .Range("A2:N" & LastRow).Cut wsMismatches.Range("A2")                                                       '       Cut Results thus far & paste to beginning of wsMismatches
            .Rows("2:" & LastRow).Delete                                                                                '       Delete the rows that were cut from wsDestination
        End If
'
'-----------------------------------------------------------------------------------------------------------------------
'
        LastRow = .Range("A" & .Rows.Count).End(xlUp).Row                                                               '   Get last used row of Column A in wsDestination
'
' =IF(COUNTIFS($B$2:$B$20000,IF($B2="PORTAL","TALLY","PORTAL"),$C$2:$C$20000,$C2,$E$2:$E$20000,$E2,$F$2:$F$20000,$F2,$G$2:$G$20000,$G2&"",$H$2:$H$20000,$H2&"",$I$2:$I$20000,$I2&"")>0,"MATCHED","")

        .Range(DestinationRemarksColumn & "2").Formula = "=IF(COUNTIFS($B$2:$B$" & LastRow & ",IF($B2=""PORTAL""," & _
                """TALLY"",""PORTAL""),$C$2:$C$" & LastRow & ",$C2,$E$2:$E$" & LastRow & ",$E2,$F$2:$F$" & _
                LastRow & ",$F2,$G$2:$G$" & LastRow & ",$G2&"""",$H$2:$H$" & LastRow & ",$H2&"""",$I$2:$I$" & LastRow & _
                ",$I2&"""")>0,""MATCHED"","""")"                                                                        '   Formula to put in DestinationRemarksColumn
'
        .Range(DestinationRemarksColumn & "2:" & DestinationRemarksColumn & LastRow).Formula = _
                .Range(DestinationRemarksColumn & "2").Formula                                                          '   Copy the formula down the range without copying the formatting
'
        .Range(DestinationRemarksColumn & "2:" & DestinationRemarksColumn & LastRow).Copy                               '   Copy formula range into memory (Clipboard)
        .Range(DestinationRemarksColumn & "2:" & DestinationRemarksColumn & LastRow).PasteSpecial xlPasteValues         '   Paste just the values back to range
''        Application.CutCopyMode = False                                                                                 '   Clear clipboard & 'marching ants' around copied range
'
        .Range("A2:N" & LastRow).Sort Key1:=.Range(DestinationRemarksColumn & "2"), Order1:=xlDescending, Header:=xlNo  '   Sort Remarks Column highest to lowest
        LastRow = .Columns(10).Find(What:="*", Lookat:=xlPart, LookIn:=xlFormulas, searchorder:=xlByRows, _
                searchdirection:=xlPrevious).Row                                                                        '   Get last used row of Column J in wsDestination
'
        If LastRow > 1 Then                                                                                             '   If we got any results then ...
            .Range("A2:N" & LastRow).Cut wsMatched.Range("A2")                                                          '       Cut Results thus far & paste to beginning of wsMatched
            .Rows("2:" & LastRow).Delete                                                                                '       Delete the rows that were cut from wsDestination
        End If
'
'-----------------------------------------------------------------------------------------------------------------------
'
        LastRow = .Range("A" & .Rows.Count).End(xlUp).Row                                                               '   Get last used row of Column A in wsDestination
'
' =IF(COUNTIFS($B$2:$B$20000,IF($B2="PORTAL","TALLY","PORTAL"),$C$2:$C$20000,$C2,$E$2:$E$20000,$E2,$G$2:$G$20000,$G2&"",$H$2:$H$20000,$H2&"",$I$2:$I$20000,$I2&"")>0,"MATCHED","")
        .Range(DestinationRemarksColumn & "2").Formula = "=IF(COUNTIFS($B$2:$B$" & LastRow & ",IF($B2=""PORTAL""," & _
                """TALLY"",""PORTAL""),$C$2:$C$" & LastRow & ",$C2,$E$2:$E$" & LastRow & ",$E2,$G$2:$G$" & LastRow & _
                ",$G2&"""",$H$2:$H$" & LastRow & ",$H2&"""",$I$2:$I$" & LastRow & ",$I2&"""")>0,""MATCHED"","""")"      '   Formula to put in DestinationRemarksColumn
'
        .Range(DestinationRemarksColumn & "2:" & DestinationRemarksColumn & LastRow).Formula = _
                .Range(DestinationRemarksColumn & "2").Formula                                                          '   Copy the formula down the range without copying the formatting
'
        .Range(DestinationRemarksColumn & "2:" & DestinationRemarksColumn & LastRow).Copy                               '   Copy formula range into memory (Clipboard)
        .Range(DestinationRemarksColumn & "2:" & DestinationRemarksColumn & LastRow).PasteSpecial xlPasteValues         '   Paste just the values back to range
        Application.CutCopyMode = False                                                                                 '   Clear clipboard & 'marching ants' around copied range
'
        .Range("A2:N" & LastRow).Sort Key1:=.Range(DestinationRemarksColumn & "2"), Order1:=xlDescending, Header:=xlNo  '   Sort Remarks Column highest to lowest
        LastRow = .Columns(10).Find(What:="*", Lookat:=xlPart, LookIn:=xlFormulas, searchorder:=xlByRows, _
                searchdirection:=xlPrevious).Row                                                                        '   Get last used row of Column J in wsDestination
'
        If LastRow > 1 Then                                                                                             '   If we got any results then ...
            .Range("A2:N" & LastRow).Cut wsMatched.Range("A" & wsMatched.Range("A" & _
                    wsMatched.Rows.Count).End(xlUp).Row + 1)                                                            '       Cut Results thus far & paste to end of wsMatched
            .Rows("2:" & LastRow).Delete                                                                                '       Delete the rows that were cut from wsDestination
        End If
'
'-----------------------------------------------------------------------------------------------------------------------
'
        LastRow = .Range("A" & .Rows.Count).End(xlUp).Row                                                               '   Get last used row of Column A in wsDestination
'
' =IF(COUNTIFS($B$2:$B$20000,IF($B2="PORTAL","TALLY","PORTAL"),$C$2:$C$20000,$C2,$G$2:$G$20000,$G2&"",$H$2:$H$20000,$H2&"",$I$2:$I$20000,$I2&"")>0,"MATCHED","")
        .Range(DestinationRemarksColumn & "2").Formula = "=IF(COUNTIFS($B$2:$B$" & LastRow & ",IF($B2=""PORTAL""," & _
                """TALLY"",""PORTAL""),$C$2:$C$" & LastRow & ",$C2,$G$2:$G$" & LastRow & _
                ",$G2&"""",$H$2:$H$" & LastRow & ",$H2&"""",$I$2:$I$" & LastRow & ",$I2&"""")>0,""MATCHED"","""")"      '   Formula to put in DestinationRemarksColumn
'
        .Range(DestinationRemarksColumn & "2:" & DestinationRemarksColumn & LastRow).Formula = _
                .Range(DestinationRemarksColumn & "2").Formula                                                          '   Copy the formula down the range without copying the formatting
'
        .Range(DestinationRemarksColumn & "2:" & DestinationRemarksColumn & LastRow).Copy                               '   Copy formula range into memory (Clipboard)
        .Range(DestinationRemarksColumn & "2:" & DestinationRemarksColumn & LastRow).PasteSpecial xlPasteValues         '   Paste just the values back to range
        Application.CutCopyMode = False                                                                                 '   Clear clipboard & 'marching ants' around copied range
'
        .Range("A2:N" & LastRow).Sort Key1:=.Range(DestinationRemarksColumn & "2"), Order1:=xlDescending, Header:=xlNo  '   Sort Remarks Column highest to lowest
        LastRow = .Columns(10).Find(What:="*", Lookat:=xlPart, LookIn:=xlFormulas, searchorder:=xlByRows, _
                searchdirection:=xlPrevious).Row                                                                        '   Get last used row of Column J in wsDestination
'
        If LastRow > 1 Then                                                                                             '   If we got any results then ...
            .Range("A2:N" & LastRow).Cut wsMatched.Range("A" & wsMatched.Range("A" & _
                    wsMatched.Rows.Count).End(xlUp).Row + 1)                                                            '       Cut Results thus far & paste to end of wsMatched
            .Rows("2:" & LastRow).Delete                                                                                '       Delete the rows that were cut from wsDestination
        End If
'
'-----------------------------------------------------------------------------------------------------------------------
'
' This formula is a duplicate formula from above !!! ;)
'
        LastRow = .Range("A" & .Rows.Count).End(xlUp).Row                                                               '   Get last used row of Column A in wsDestination
'
' =IF(COUNTIFS($B$2:$B$20000,IF($B2="PORTAL","TALLY","PORTAL"),$C$2:$C$20000,$C2,$E$2:$E$20000,$E2,$G$2:$G$20000,$G2&"",$H$2:$H$20000,$H2&"",$I$2:$I$20000,$I2&"")>0,"MATCHED","")
        .Range(DestinationRemarksColumn & "2").Formula = "=IF(COUNTIFS($B$2:$B$" & LastRow & ",IF($B2=""PORTAL""," & _
                """TALLY"",""PORTAL""),$C$2:$C$" & LastRow & ",$C2,$E$2:$E$" & LastRow & ",$E2,$G$2:$G$" & LastRow & _
                ",$G2&"""",$H$2:$H$" & LastRow & ",$H2&"""",$I$2:$I$" & LastRow & ",$I2&"""")>0,""MATCHED"","""")"      '   Formula to put in DestinationRemarksColumn
'
        .Range(DestinationRemarksColumn & "2:" & DestinationRemarksColumn & LastRow).Formula = _
                .Range(DestinationRemarksColumn & "2").Formula                                                          '   Copy the formula down the range without copying the formatting
'
        .Range(DestinationRemarksColumn & "2:" & DestinationRemarksColumn & LastRow).Copy                               '   Copy formula range into memory (Clipboard)
        .Range(DestinationRemarksColumn & "2:" & DestinationRemarksColumn & LastRow).PasteSpecial xlPasteValues         '   Paste just the values back to range
        Application.CutCopyMode = False                                                                                 '   Clear clipboard & 'marching ants' around copied range
'
        .Range("A2:N" & LastRow).Sort Key1:=.Range(DestinationRemarksColumn & "2"), Order1:=xlDescending, Header:=xlNo  '   Sort Remarks Column highest to lowest
        LastRow = .Columns(10).Find(What:="*", Lookat:=xlPart, LookIn:=xlFormulas, searchorder:=xlByRows, _
                searchdirection:=xlPrevious).Row                                                                        '   Get last used row of Column J in wsDestination
'
        If LastRow > 1 Then                                                                                             '   If we got any results then ...
            .Range("A2:N" & LastRow).Cut wsMatched.Range("A" & wsMatched.Range("A" & _
                    wsMatched.Rows.Count).End(xlUp).Row + 1)                                                            '       Cut Results thus far & paste to end of wsMatched
            .Rows("2:" & LastRow).Delete                                                                                '       Delete the rows that were cut from wsDestination
        End If
'
'-----------------------------------------------------------------------------------------------------------------------
'
        LastRow = .Range("A" & .Rows.Count).End(xlUp).Row                                                               '   Get last used row of Column A in wsDestination
'
' =IF(IF($G2<>"",COUNTIFS($B:$B,IF($B2="PORTAL","TALLY","PORTAL"),$C:$C,$C2,$E:$E,$E2,$F:$F,$F2,$G:$G,">="&($G2-1),$G:$G,"<="&($G2+1)),COUNTIFS($B:$B,IF($B2="PORTAL","TALLY","PORTAL"),$C:$C,$C2,$E:$E,$E2,$F:$F,$F2,$H:$H,">="&($H2-1),$H:$H,"<="&($H2+1),$I:$I,">="&($I2-1),$I:$I,"<="&($I2+1)))>0,"MATCHED","")
        .Range(DestinationRemarksColumn & "2").Formula = "=IF(IF($G2<>"""",COUNTIFS($B:$B,IF($B2=""PORTAL"",""TALLY""," & _
                """PORTAL""),$C:$C,$C2,$E:$E,$E2,$F:$F,$F2,$G:$G,"">=""&($G2-1),$G:$G,""<=""&($G2+1)),COUNTIFS($B:$B," & _
                "IF($B2=""PORTAL"",""TALLY"",""PORTAL""),$C:$C,$C2,$E:$E,$E2,$F:$F,$F2,$H:$H,"">=""&($H2-1)," & _
                "$H:$H,""<=""&($H2+1),$I:$I,"">=""&($I2-1),$I:$I,""<=""&($I2+1)))>0,""MATCHED"","""")"                  '   Formula to put in DestinationRemarksColumn
'
        .Range(DestinationRemarksColumn & "2:" & DestinationRemarksColumn & LastRow).Formula = _
                .Range(DestinationRemarksColumn & "2").Formula                                                          '   Copy the formula down the range without copying the formatting
'
        .Range(DestinationRemarksColumn & "2:" & DestinationRemarksColumn & LastRow).Copy                               '   Copy formula range into memory (Clipboard)
        .Range(DestinationRemarksColumn & "2:" & DestinationRemarksColumn & LastRow).PasteSpecial xlPasteValues         '   Paste just the values back to range
        Application.CutCopyMode = False                                                                                 '   Clear clipboard & 'marching ants' around copied range
'
        .Range("A2:N" & LastRow).Sort Key1:=.Range(DestinationRemarksColumn & "2"), Order1:=xlDescending, Header:=xlNo  '   Sort Remarks Column highest to lowest
        LastRow = .Columns(10).Find(What:="*", Lookat:=xlPart, LookIn:=xlFormulas, searchorder:=xlByRows, _
                searchdirection:=xlPrevious).Row                                                                        '   Get last used row of Column J in wsDestination
'
        If LastRow > 1 Then                                                                                             '   If we got any results then ...
            .Range("A2:N" & LastRow).Cut wsMatched.Range("A" & wsMatched.Range("A" & _
                    wsMatched.Rows.Count).End(xlUp).Row + 1)                                                            '       Cut Results thus far & paste to end of wsMatched
            .Rows("2:" & LastRow).Delete                                                                                '       Delete the rows that were cut from wsDestination
        End If
'
'-----------------------------------------------------------------------------------------------------------------------
'
' Something wrong with this formula ??? It doesn't paste as a formula
'
        LastRow = .Range("A" & .Rows.Count).End(xlUp).Row                                                               '   Get last used row of Column A in wsDestination
'
' =IF(IF($G2<>"",COUNTIFS($B:$B,IF($B2="PORTAL","TALLY","PORTAL"),$C:$C,$C2,$E:$E,$E2,$G:$G,">="&($G2-1),$G:$G,"<="&($G2+1)),COUNTIFS($B:$B,IF($B2="PORTAL","TALLY","PORTAL"),$C:$C,$C2,$E:$E,$E2,$H:$H,">="&($H2-1),$H:$H,"<="&($H2+1),$I:$I,">="&($I2-1),$I:$I,"<="&($I2+1)))>0,"MATCHED","")
        .Range(DestinationRemarksColumn & "2").Formula = "=IF(IF($G2<>"""",COUNTIFS($B:$B,IF($B2=""PORTAL"",""TALLY""," & _
                """PORTAL""),$C:$C,$C2,$E:$E,$E2,$G:$G,"">=""&($G2-1),$G:$G,""<=""&($G2+1)),COUNTIFS($B:$B," & _
                "IF($B2=""PORTAL"",""TALLY"",""PORTAL""),$C:$C,$C2,$E:$E,$E2,$H:$H,"">=""&($H2-1),$H:$H,""<=""&" & _
                "($H2+1),$I:$I,"">=""&($I2-1),$I:$I,""<=""&($I2+1)))>0,""MATCHED"","""")"                               '   Formula to put in DestinationRemarksColumn
'
        .Range(DestinationRemarksColumn & "2:" & DestinationRemarksColumn & LastRow).Formula = _
                .Range(DestinationRemarksColumn & "2").Formula                                                          '   Copy the formula down the range without copying the formatting
'
        .Range(DestinationRemarksColumn & "2:" & DestinationRemarksColumn & LastRow).Copy                               '   Copy formula range into memory (Clipboard)
        .Range(DestinationRemarksColumn & "2:" & DestinationRemarksColumn & LastRow).PasteSpecial xlPasteValues         '   Paste just the values back to range
        Application.CutCopyMode = False                                                                                 '   Clear clipboard & 'marching ants' around copied range
'
        .Range("A2:N" & LastRow).Sort Key1:=.Range(DestinationRemarksColumn & "2"), Order1:=xlDescending, Header:=xlNo  '   Sort Remarks Column highest to lowest
        LastRow = .Columns(10).Find(What:="*", Lookat:=xlPart, LookIn:=xlFormulas, searchorder:=xlByRows, _
                searchdirection:=xlPrevious).Row                                                                        '   Get last used row of Column J in wsDestination
'
        If LastRow > 1 Then                                                                                             '   If we got any results then ...
            .Range("A2:N" & LastRow).Cut wsMatched.Range("A" & wsMatched.Range("A" & _
                    wsMatched.Rows.Count).End(xlUp).Row + 1)                                                            '       Cut Results thus far & paste to end of wsMatched
            .Rows("2:" & LastRow).Delete                                                                                '       Delete the rows that were cut from wsDestination
        End If
'
'-----------------------------------------------------------------------------------------------------------------------
'
        LastRow = .Range("A" & .Rows.Count).End(xlUp).Row                                                               '   Get last used row of Column A in wsDestination
'
' =IF(COUNTIFS($B:$B,IF($B2="PORTAL","TALLY","PORTAL"),IF($G2<>"",$G:$G,$H:$H),">="&(IF($G2<>"",$G2,$H2)-1),IF($G2<>"",$G:$G,$H:$H),"<="&(IF($G2<>"",$G2,$H2)+1))>0,"MATCHED","Not Found")
        .Range(DestinationRemarksColumn & "2").Formula = "=IF(COUNTIFS($B:$B,IF($B2=""PORTAL"",""TALLY"",""PORTAL"")" & _
                ",IF($G2<>"""",$G:$G,$H:$H),"">=""&(IF($G2<>"""",$G2,$H2)-1),IF($G2<>"""",$G:$G,$H:$H),""<=""&" & _
                "(IF($G2<>"""",$G2,$H2)+1))>0,""MATCHED"","""")"                                                        '   Formula to put in DestinationRemarksColumn
'
        .Range(DestinationRemarksColumn & "2:" & DestinationRemarksColumn & LastRow).Formula = _
                .Range(DestinationRemarksColumn & "2").Formula                                                          '   Copy the formula down the range without copying the formatting
'
        .Range(DestinationRemarksColumn & "2:" & DestinationRemarksColumn & LastRow).Copy                               '   Copy formula range into memory (Clipboard)
        .Range(DestinationRemarksColumn & "2:" & DestinationRemarksColumn & LastRow).PasteSpecial xlPasteValues         '   Paste just the values back to range
        Application.CutCopyMode = False                                                                                 '   Clear clipboard & 'marching ants' around copied range
'
        .Range("A2:N" & LastRow).Sort Key1:=.Range(DestinationRemarksColumn & "2"), Order1:=xlDescending, Header:=xlNo  '   Sort Remarks Column highest to lowest
        LastRow = .Columns(10).Find(What:="*", Lookat:=xlPart, LookIn:=xlFormulas, searchorder:=xlByRows, _
                searchdirection:=xlPrevious).Row                                                                        '   Get last used row of Column J in wsDestination
'
        If LastRow > 1 Then                                                                                             '   If we got any results then ...
            .Range("A2:N" & LastRow).Cut wsMatched.Range("A" & wsMatched.Range("A" & _
                    wsMatched.Rows.Count).End(xlUp).Row + 1)                                                            '       Cut Results thus far & paste to end of wsMatched
            .Rows("2:" & LastRow).Delete                                                                                '       Delete the rows that were cut from wsDestination
        End If
'
'-----------------------------------------------------------------------------------------------------------------------
'
        LastRow = .Range("A" & .Rows.Count).End(xlUp).Row                                                               '   Get last used row of Column A in wsDestination
'
' =IF(COUNTIFS($B:$B,IF($B2="PORTAL","TALLY","PORTAL"),IF($G2<>"",$G:$G,$H:$H),">="&(IF($G2<>"",$G2,$H2)-1),IF($G2<>"",$G:$G,$H:$H),"<="&(IF($G2<>"",$G2,$H2)+1))>0,"MATCHED","Not Found")
        .Range(DestinationRemarksColumn & "2").Formula = "=IF(COUNTIFS($B:$B,IF($B2=""PORTAL"",""TALLY"",""PORTAL"")" & _
                ",IF($G2<>"""",$G:$G,$H:$H),"">=""&(IF($G2<>"""",$G2,$H2)-1),IF($G2<>"""",$G:$G,$H:$H),""<=""&" & _
                "(IF($G2<>"""",$G2,$H2)+1))>0,"""",""Not Found"")"                                                      '   Formula to put in DestinationRemarksColumn
'
        .Range(DestinationRemarksColumn & "2:" & DestinationRemarksColumn & LastRow).Formula = _
                .Range(DestinationRemarksColumn & "2").Formula                                                          '   Copy the formula down the range without copying the formatting
'
        .Range(DestinationRemarksColumn & "2:" & DestinationRemarksColumn & LastRow).Copy                               '   Copy formula range into memory (Clipboard)
        .Range(DestinationRemarksColumn & "2:" & DestinationRemarksColumn & LastRow).PasteSpecial xlPasteValues         '   Paste just the values back to range
        Application.CutCopyMode = False                                                                                 '   Clear clipboard & 'marching ants' around copied range
'
        .Range("A2:N" & LastRow).Sort Key1:=.Range(DestinationRemarksColumn & "2"), Order1:=xlDescending, Header:=xlNo  '   Sort Remarks Column highest to lowest
        LastRow = .Columns(10).Find(What:="*", Lookat:=xlPart, LookIn:=xlFormulas, searchorder:=xlByRows, _
                searchdirection:=xlPrevious).Row                                                                        '   Get last used row of Column J in wsDestination
'
        If LastRow > 1 Then                                                                                             '   If we got any results then ...
            .Range("A2:N" & LastRow).Cut wsMismatches.Range("A" & wsMismatches.Range("A" & _
                    wsMismatches.Rows.Count).End(xlUp).Row + 1)                                                         '       Cut Results thus far & paste to end of wsMismatches
            .Rows("2:" & LastRow).Delete                                                                                '       Delete the rows that were cut from wsDestination
        End If
    End With
'
'-----------------------------------------------------------------------------------------------------------------------
'
    Call CheckSubTotal                                                                                                  '
'
    Application.ScreenUpdating = True                                                                                   ' Turn ScreenUpdating back on
'
    If wsMismatches.Range("B2") = "" Then MsgBox "No MisMatches Found"                                                  ' If No MisMatches Found, tell the user
End Sub


Sub GetDataFromDataSheet(DataWorkSheet As String)
'
    Dim ArrayColumn                 As Long, ArrayRow       As Long
    Dim DataLastColumn              As String, DataLastRow  As Long, DestinationStartRow    As Long
    Dim CorrectedDataArray          As Variant
    Dim DataSheetArray              As Variant
'
    With Sheets(DataWorkSheet)
        DataLastRow = .Range("A" & .Rows.Count).End(xlUp).Row                                                           '   Get last row of the Data sheet column B
'
        DataLastColumn = Split(Cells(1, (.Cells.Find("*", _
            , xlFormulas, , xlByColumns, xlPrevious).Column)).Address, "$")(1)                                          '   Get last column letter of the Data sheet
'
        .Columns("E:E").NumberFormat = "General"                                                                        '   Set date column to General format
'
        DataSheetArray = .Range("A2:" & DataLastColumn & DataLastRow)                                                   '   Load Data from Data sheet to 2D 1 based DataSheetArray
'
        .Columns("E:E").NumberFormat = "m/d/yyyy"                                                                       '   Change date column back to standard date
    End With
'
    ReDim CorrectedDataArray(1 To UBound(DataSheetArray, 1), 1 To UBound(DataSheetArray, 2) + 2)                        ' Set the number of rows & columns for the CorrectedDataArray
'
    For ArrayRow = 1 To UBound(DataSheetArray, 1)                                                                       ' Loop through the rows of DataSheetArray
        For ArrayColumn = 1 To UBound(CorrectedDataArray, 2)                                                            '   Loop through the columns of CorrectedDataArray
            Select Case ArrayColumn
                Case 2
                    CorrectedDataArray(ArrayRow, ArrayColumn) = "TALLY"                                                 '       Save DataSheetArray data into CorrectedDataArray

                Case 1, 10:                                                                                             '       Skip these Columns, Leave the column blank
                Case 12:
                    CorrectedDataArray(ArrayRow, ArrayColumn) = DataSheetArray(ArrayRow, ArrayColumn - 3)               '       Save DataSheetArray data into CorrectedDataArray
                Case Else
                    CorrectedDataArray(ArrayRow, ArrayColumn) = DataSheetArray(ArrayRow, ArrayColumn - 1)               '       Save DataSheetArray data into CorrectedDataArray
            End Select
        Next                                                                                                            '   Loop back
    Next                                                                                                                ' Loop back
'
    DestinationStartRow = DestinationLastRow + 1                                                                        ' Save DestinationLastRow + 1 into DestinationStartRow
'
    With wsDestination
        .Range("A" & DestinationStartRow).Resize(UBound(CorrectedDataArray, _
            1), UBound(CorrectedDataArray, 2)) = CorrectedDataArray                                                     '   Display Results to destination sheet
'
        .Range("F:F").NumberFormat = "dd-mm-yyyy"                                                                       '   Format the date the way we want it to appear
'
        .Columns("M:M").TextToColumns Destination:=.Range("M1"), DataType:=xlDelimited, FieldInfo:=Array(1, 4)          '   Convert text to numeric
'
        DestinationLastRow = .Range("B" & .Rows.Count).End(xlUp).Row                                                    '   Recalculate last row used in column B of the destination sheeet
'
        .Range("N" & DestinationStartRow & ":N" & DestinationLastRow) = "As per " & DataWorkSheet                       '   Copy 'As Per ' & sheet name to Column N
'
        .Range("A" & DestinationStartRow & ":A" & DestinationLastRow).Formula = "=Row() - 1"                            '   Use formula to set row #s
        .Range("A" & DestinationStartRow & ":A" & DestinationLastRow).Copy                                              '   Copy formula range into memory (clipboard)
        .Range("A" & DestinationStartRow & ":A" & DestinationLastRow).PasteSpecial xlPasteValues                        '   Paste just the vales back to range
        Application.CutCopyMode = False                                                                                 '   Clear clipboard & 'marching ants' around copied range
    End With
End Sub


A few things I noticed, A few of the formulas need to be looked at.
1) Your 2nd formula and your fourth formula are the same?
2) Some of your formulas do not yield any results, I assume that is because of the limited data sample?
3) Your 2nd to last formula doesn't appear to paste properly.

I have also 'split' your last formula to make it easier to copy the results to the proper sheets.

I think I have touched a lot of bases with this version of code. Let me know which ones I missed after you test the new code.
Click to expand...
Sorry. I didn't notice that I missed one of the formulas. There are six formulas and I have shared only 5 of them. One of them is a repeat. My bad. I will share the 6 formulas once again.
 
Upvote 0
johnnyL said:
Some of your formulas do not yield any results, I assume that is because of the limited data sample?
Click to expand...
Yes and also If there are no matches as per the formula, then it will show only blank.
 
Upvote 0
johnnyL said:
1) Your 2nd formula and your fourth formula are the same?
Click to expand...
formula 4 is
Rich (BB code): 
=IF(IF($G2<>"",COUNTIFS($B:$B,IF($B2="PORTAL","TALLY","PORTAL"),$C:$C,$C2,$E:$E,$E2,$F:$F,$F2,$G:$G,">="&($G2-1),$G:$G,"<="&($G2+1)),COUNTIFS($B:$B,IF($B2="PORTAL","TALLY","PORTAL"),$C:$C,$C2,$E:$E,$E2,$F:$F,$F2,$H:$H,">="&($H2-1),$H:$H,"<="&($H2+1),$I:$I,">="&($I2-1),$I:$I,"<="&($I2+1)))>0,"MATCHED","")
 
Upvote 0
The result is satisfactory. The combined data sheet needs to be filled with data and the remarks and not to be left empty. Other things like sorting the data in each sheet are all small things which can be done later. As for the matches and mismatches I need to check all the rows from the beginning as you noticed one of the formulas is a repeat.
I know it is your time to hit the sack. I will go through the code and make a list of issues if any and will post them by tonight.
 
Upvote 0
👏👏👍JohnnyL. I don't know how you did it but everything is as expected. It is really great man. The code is excellent. I tried to write the code for the below mentioned pending steps to be done, but was not sure where to place the lines exactly. So, leaving the coding part to you only.
The duplicate formula need to be replaced with the formula shared in post #34.
The used range entire column autofit to be added to all the created sheets.
The sort function of each sheet same as before to be added.
Finally, the Combined data Sheet to be restored by joining the 2 sheets mismatches and Matched and sort it as before.
Once you are finished with this I will check it out on a larger data and revert back.
 
Upvote 0
On a dummy sheet, I inserted 6 columns for the 6 formulas and this is the way I found the precise Matches and mismatches. For your reference I am sharing the worksheet.
Loading Google Sheets
 
Upvote 0
Book1
AB
11=IF(COUNTIFS($B$2:$B$20000,IF($B2="PORTAL","TALLY","PORTAL"),$C$2:$C$20000,$C2,$E$2:$E$20000,$E2,$F$2:$F$20000,$F2,$G$2:$G$20000,$G2&"",$H$2:$H$20000,$H2&"",$I$2:$I$20000,$I2&"")>0,"MATCHED","")
22=IF(COUNTIFS($B$2:$B$20000,IF($B2="PORTAL","TALLY","PORTAL"),$C$2:$C$20000,$C2,$E$2:$E$20000,$E2,$G$2:$G$20000,$G2&"",$H$2:$H$20000,$H2&"",$I$2:$I$20000,$I2&"")>0,"MATCHED","")
33=IF(COUNTIFS($B$2:$B$20000,IF($B2="PORTAL","TALLY","PORTAL"),$C$2:$C$20000,$C2,$G$2:$G$20000,$G2&"",$H$2:$H$20000,$H2&"",$I$2:$I$20000,$I2&"")>0,"MATCHED","")
44=IF(IF($G2<>"",COUNTIFS($B:$B,IF($B2="PORTAL","TALLY","PORTAL"),$C:$C,$C2,$E:$E,$E2,$F:$F,$F2,$G:$G,">="&($G2-1),$G:$G,"<="&($G2+1)),COUNTIFS($B:$B,IF($B2="PORTAL","TALLY","PORTAL"),$C:$C,$C2,$E:$E,$E2,$F:$F,$F2,$H:$H,">="&($H2-1),$H:$H,"<="&($H2+1),$I:$I,">="&($I2-1),$I:$I,"<="&($I2+1)))>0,"MATCHED","")
55=IF(IF($G2<>"",COUNTIFS($B:$B,IF($B2="PORTAL","TALLY","PORTAL"),$C:$C,$C2,$E:$E,$E2,$G:$G,">="&($G2-1),$G:$G,"<="&($G2+1)),COUNTIFS($B:$B,IF($B2="PORTAL","TALLY","PORTAL"),$C:$C,$C2,$E:$E,$E2,$H:$H,">="&($H2-1),$H:$H,"<="&($H2+1),$I:$I,">="&($I2-1),$I:$I,"<="&($I2+1)))>0,"MATCHED","")
66=IF(IF($G2<>"",COUNTIFS($B:$B,IF($B2="PORTAL","TALLY","PORTAL"),$C:$C,$C2,$G:$G,">="&($G2-1),$G:$G,"<="&($G2+1)),COUNTIFS($B:$B,IF($B2="PORTAL","TALLY","PORTAL"),$C:$C,$C2,$H:$H,">="&($H2-1),$H:$H,"<="&($H2+1),$I:$I,">="&($I2-1),$I:$I,"<="&($I2+1)))>0,"MATCHED","Not Found")
Formulas

This is the right order of formulas to be applied in code. The last formula is different / wrong in your code.
 
Upvote 0
You must log in or register to reply here.

Similar threads

P
  • Solved
VBA Match data, find mismatch data and copy data to validation sheet. Not working correctly.
2
Replies
16
Views
757
pawcoyote
P
P
  • Question
Macro to import multile xml into xlsm with Map data properties or schema
Replies
5
Views
77
Kerryx
K
J
  • Solved
VBA Project (Automatic Update) and Macro reference with file name change
Replies
8
Views
295
JDSOuth49
J
M
  • Question
Excel pivot table query - retaining filters on pivot in absence of data
2
Replies
10
Views
969
Alex Blakenburg
A
I
  • Question
Edit existing code from a specific cell to active cell
Replies
3
Views
271
ipbr21054
I

Forum statistics

Threads
1,214,620
Messages
6,120,554
Members
448,970
Latest member
kennimack

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