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
Dim ColumnFirstBlankValueRow 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 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 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")
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.ClearContents ' Delete previous contents from destination sheet
wsDestination.Range("A1:N1").Value = HeaderTitlesToPaste ' Write header row to DestinationSheet
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.ClearContents ' Delete previous contents from Matches sheet
wsMatched.Range("A1:N1").Value = HeaderTitlesToPaste ' Write header row to MatchedSheet
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.ClearContents ' Delete previous contents from Mismatches sheet
wsMismatches.Range("A1:N1").Value = HeaderTitlesToPaste ' Write header row to MismatchesSheet
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:M" & DestinationLastRow).Interior.Color = RGB(146, 208, 80) ' Highlight the range green
.Range("B2:M" & 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
'
.Range("M:M").NumberFormat = "dd-mm-yyyy" ' Format the date the way we want it to appear
' Application.CutCopyMode = False ' Clear clipboard & 'marching ants' around copied range
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
'
HeaderTitle = "Integrated Tax" ' Set the header title we will look for & sort
Call SortColumnAndApplyFormulas(HeaderTitle) ' Pass HeaderTitle to the sub routine
'
HeaderTitle = "Central Tax" ' Set the header title we will look for & sort
Call SortColumnAndApplyFormulas(HeaderTitle) ' Pass HeaderTitle to the sub routine
'
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
', FormulaVersion:=xlReplaceFormula ' xxx Added Replace 0 with blank
.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
'
'---------------------------------------------------------------
'
DestintionArray = wsDestination.Range("A2:" & SourceDataLastWantedColumn & _
DestinationLastRow) ' Load all needed data from destination sheet to
' ' 2D 1 based DestintionArray RC
ReDim MatchedArray(1 To UBound(DestintionArray, 1), 1 To UBound(DestintionArray, 2)) ' Set the # of rows and columns for MatchedArray
ReDim MismatchesArray(1 To UBound(DestintionArray, 1), 1 To UBound(DestintionArray, 2)) ' Set the # of rows and columns for MismatchesArray
'
MatchedRow = 0 ' Initialize MatchedRow
MismatchesRow = 0 ' Initialize MismatchesRow
'
For ArrayRow = 1 To UBound(DestintionArray, 1) ' Loop through DestintionArray rows
On Error GoTo ErrorFound
'
Select Case DestintionArray(ArrayRow, 10) ' Get value from column J
Case Is = "Matched" ' If value = 'Matched' then ...
MatchedRow = MatchedRow + 1 ' Increment MatchedRow
'
For ArrayColumn = 1 To UBound(DestintionArray, 2) ' Loop through DestintionArray columns
MatchedArray(MatchedRow, ArrayColumn) = DestintionArray(ArrayRow, ArrayColumn) ' Save Destination cell to MatchedArray
Next ' Loop back
Case Else
ErrorFound:
Resume Continue ' Clear error if it exists
Continue:
On Error GoTo 0 ' Turn Excel error handling back on
MismatchesRow = MismatchesRow + 1 ' Increment MismatchesRow
'
'
For ArrayColumn = 1 To UBound(DestintionArray, 2) ' Loop through DestintionArray columns
MismatchesArray(MismatchesRow, ArrayColumn) = DestintionArray(ArrayRow, ArrayColumn) ' Save Destination cell to MismatchesArray
Next ' Loop back
End Select
Next ' Loop back
'
With wsMatched
.Range("A2").Resize(UBound(MatchedArray, 1), UBound(MatchedArray, 2)) = MatchedArray ' Display results to Matched sheet
'
For Each Cel In .Range("B2:B" & .Range("B" & Rows.Count).End(xlUp).Row) ' Loop through all cells in column B on the Matched sheet
If Cel.Value = "PORTAL" Then ' If Cell value is 'PORTAL' then ...
'' Cel.EntireRow.Interior.Color = RGB(146, 208, 80) ' Color the row
'' Cel.EntireRow.Font.Bold = True ' Bold the row
.Range("A" & Cel.Row & ":N" & Cel.Row).Interior.Color = RGB(146, 208, 80) ' Color the columns
.Range("A" & Cel.Row & ":N" & Cel.Row).Font.Bold = True ' Bold the columns
End If
Next ' Loop back
End With
'
With wsMismatches
.Range("A2").Resize(UBound(MismatchesArray, 1), UBound(MismatchesArray, 2)) = MismatchesArray ' Display results to Mismatches sheet
'
For Each Cel In .Range("B2:B" & .Range("B" & Rows.Count).End(xlUp).Row) ' Loop through all cells in column B on the Mismatches sheet
If Cel.Value = "PORTAL" Then ' If Cell value is 'PORTAL' then ...
'' Cel.EntireRow.Interior.Color = RGB(146, 208, 80) ' Color the row
'' Cel.EntireRow.Font.Bold = True ' Bold the row
.Range("A" & Cel.Row & ":N" & Cel.Row).Interior.Color = RGB(146, 208, 80) ' Color the columns
.Range("A" & Cel.Row & ":N" & Cel.Row).Font.Bold = True ' Bold the columns
End If
Next ' Loop back
End With
'
' sortrange edited by Domenic
'RANGE SORTER ... Most important column to least important column 3,6,2
Dim SortRange As Range
With wsDestination
Set SortRange = .Range("A2:N" & .Cells(.Rows.Count, "B").End(xlUp).Row)
End With
With wsDestination.Sort.SortFields
.Clear
.Add key:=Range("C2"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.Add key:=Range("G2"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.Add key:=Range("H2"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.Add key:=Range("B2"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
End With
With wsDestination
.UsedRange.EntireColumn.AutoFit ' Autofit all of the columns on the MismatchesSheet
End With
With wsDestination.Sort
.SetRange SortRange
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
'
' sortrange edited by Domenic
' RANGE SORTER ... Most important column to least important column 3,6,2
With wsDestination
Set SortRange = .Range("A2:N" & .Cells(.Rows.Count, "B").End(xlUp).Row)
End With
With wsMatched.Sort.SortFields
.Clear
.Add key:=Range("C2"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.Add key:=Range("G2"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.Add key:=Range("H2"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.Add key:=Range("B2"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
End With
With wsMatched.Sort
.SetRange SortRange
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
With wsMatched
.UsedRange.EntireColumn.AutoFit ' Autofit all of the columns on the MismatchesSheet
End With
' RANGE SORTER ... Most important column to least important column 3,6,2
With wsMismatches
.Range("A2:N" & .Range("B" & Rows.Count).End(xlUp).Row).Sort _
Key1:=.Range("G2"), Order1:=xlAscending, _
Key2:=.Range("H2"), Order1:=xlAscending, _
Key3:=.Range("B2"), Order1:=xlAscending, Header:=xlNo ' Sort the Mismatches sheet by various columns
.UsedRange.EntireColumn.AutoFit ' Autofit all of the columns on the MismatchesSheet
End With
'
Call CheckSubTotal
'
'
'
Dim LastRow As Long
'
With Sheets("Combined Data")
LastRow = .Range("A" & .Rows.Count).End(xlUp).Row
'
With .Range("A2:N" & LastRow)
.FormatConditions.Add Type:=xlExpression, Formula1:= _
"=SUMPRODUCT(($C$2:$C$" & LastRow & "=$C2)*($G$2:$G$" & LastRow & ">$G2-1)*($G$2:$G$" & LastRow & "<$G2+1)*($H$2:$H$" & _
LastRow & ">$H2-1)*($H$2:$H$" & LastRow & "<$H2+1)*($I$2:$I$" & LastRow & ">$I2-1)*($I$2:$I$" & LastRow & "<$I2+1))>2"
'
.FormatConditions(.FormatConditions.Count).SetFirstPriority
.FormatConditions(1).Interior.Color = 65535
.FormatConditions(1).StopIfTrue = False
End With
End With
'
'----------------------------------------------------------------------------------------------------------------------------------------------
'
Set SortRange = Sheets("Combined Data").Range("A2:N" & LastRow)
'
With Sheets("Combined Data").Sort.SortFields
.Clear
.Add(key:=Range("C2"), SortOn:=xlSortOnCellColor, Order:=xlAscending, DataOption:=xlSortNormal).SortOnValue.Color = RGB(255, 255, 0)
.Add key:=Range("C2"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.Add key:=Range("G2"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.Add key:=Range("H2"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.Add key:=Range("B2"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
End With
'
With Sheets("Combined Data").Sort
.SetRange SortRange
.Apply
End With
'
'
'
Application.ScreenUpdating = True ' Turn ScreenUpdating back on
'
If Sheets("Mismatches").Range("B2") = "" Then MsgBox "No MisMatches Found" ' If No MisMatches Found, tell the user
End Sub
