Option Explicit
Dim DestinationLastRow As Long
Dim DestinationRemarksColumn As String
Dim wsDestination As Worksheet
Sub New_Updated()
'
'solved by JohnnyL 30-03-2022
'Updated on 04-04-2022
'
Application.ScreenUpdating = False ' Turn ScreenUpdating off
'
Dim DestinationSheetExists As Boolean, MatchedSheetExists As Boolean, MismatchesSheetExists As Boolean
Dim ColumnFirstBlankValueRow As Long
Dim OutputArrayRow As Long, SourceArrayRow As Long
Dim SourceDataStartRow As Long, SourceLastRow As Long
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 OutputArray As Variant, SourceArray As Variant
Dim HeaderTitlesToPaste As Variant
Dim wsMatched As Worksheet, wsMismatches As Worksheet
Dim wsSource As Worksheet, ws As Worksheet
'
DestinationSheet = "Edited Portal" ' <--- 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
'
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
On Error GoTo 0 ' Turn Excel error handling back on
'
' Create DestinationSheet if it doesn't exist
If Not wsDestination Is Nothing Then DestinationSheetExists = True ' Check to see if the DestinationSheet exists
If DestinationSheetExists = False Then ' If DestinationSheet does not exist then ...
Sheets.Add(after:=wsSource).Name = DestinationSheet ' Create the DestinationSheet after the Source sheet
Set wsDestination = Sheets(DestinationSheet) ' Assign the DestinationSheet to wsDestination
End If
'
' Create MatchedSheet if it doesn't exist
If Not wsMatched Is Nothing Then MatchedSheetExists = True ' Check to see if the MatchedSheet exists
If MatchedSheetExists = False Then ' If MatchedSheet does not exist then ...
Sheets.Add(after:=wsSource).Name = MatchedSheet ' Create the MatchedSheet after the Source sheet
Set wsMatched = Sheets(MatchedSheet) ' Assign the MatchedSheet to wsMatched
End If
'
' Create MismatchesSheet if it doesn't exist
If Not wsMismatches Is Nothing Then MismatchesSheetExists = True ' Check to see if the MismatchesSheet exists
If MatchedSheetExists = False Then ' If MismatchesSheet does not exist then ...
Sheets.Add(after:=wsSource).Name = MismatchesSheet ' Create the MismatchesSheet after the Source sheet
Set wsMismatches = Sheets(MismatchesSheet) ' Assign the MismatchesSheet to wsMismatches
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, 15) = "As Per Portal" ' 'As Per Portal'
End If
Next
'
'---------------------------------------------------------------
'
wsDestination.UsedRange.Clear ' Delete previous contents from destination sheet
wsMatched.UsedRange.Clear ' Delete any previous contents from MatchedSheet
wsMismatches.UsedRange.Clear ' Delete any previous contents from MismatchesSheet
'
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", "Narration", "Data from") ' Header row to paste to desired sheets
'
' Write header values into the DestinationSheet, MatchedSheet, & MismatchesSheet
wsDestination.Range("A1:O1").Value = HeaderTitlesToPaste ' Write header row to DestinationSheet
wsMatched.Range("A1:O1").Value = HeaderTitlesToPaste ' Write header row to MatchedSheet
wsMismatches.Range("A1:O1").Value = HeaderTitlesToPaste ' Write header row to MismatchesSheet
'
wsDestination.Columns("F:F").NumberFormat = "@" ' Set column to text format to prevent excel changing dates
wsDestination.Range("A2").Resize(UBound(OutputArray, 1), UBound(OutputArray, 2)) = OutputArray ' Display results to DestinationSheet
'
DestinationLastRow = wsDestination.Range("A" & wsDestination.Rows.Count).End(xlUp).Row ' Get last row used in column A of the destination sheeet
'
wsDestination.Range("N2:N" & DestinationLastRow).Formula = "=$C$1 & "" "" & C2" & _
" & "" "" & $D$1 & "" "" & D2 & "" "" & $E$1 & "" "" & E2" & _
" & "" "" & $F$1 & "" "" & TEXT(F2,""dd-mm-yyyy"") & "" "" & $K$1" & _
" & "" "" & K2 & "" "" & $M$1 & "" "" & TEXT(M2,""DD-MM-YYYY"")" ' Copy Narration Formula to Column N
'
wsDestination.Range("O2:O" & DestinationLastRow) = "As Per Portal" ' Copy 'As Per Portal' to Column O
wsDestination.Range("G:I", "K:L").NumberFormat = "0.00" ' Set columns to numeric with 2 decimal places
'
wsDestination.Range("N2:N" & DestinationLastRow).Copy ' Copy formula range into memory
wsDestination.Range("N2:N" & DestinationLastRow).PasteSpecial xlPasteValues ' Paste just the vales back to range
Application.CutCopyMode = False ' Clear clipboard & 'marching ants' around copied range
'
wsDestination.Range("F:F").NumberFormat = "dd-mm-yyyy" ' Format the date the way we want it to appear
wsDestination.Columns("F:F").TextToColumns Destination:=Range("F1"), _
DataType:=xlDelimited, FieldInfo:=Array(1, 4) ' Convert text to numeric
'
wsDestination.Range("M:M").NumberFormat = "dd-mm-yyyy" ' Format the date the way we want it to appear
wsDestination.Columns("M:M").TextToColumns Destination:=Range("M1"), _
DataType:=xlDelimited, FieldInfo:=Array(1, 4) ' Convert text to numeric
'
wsDestination.Range("B2:M" & DestinationLastRow).Interior.Color = RGB(146, 208, 80) ' Highlight the range green
wsDestination.Range("B2:M" & DestinationLastRow).Font.Bold = True ' Make the range Bold
'
'---------------------------------------------------------------
'
For Each ws In Worksheets ' Loop through all worksheets in the workbook
Select Case ws.Name
Case Is = SourceSheet, DestinationSheet, "Expected Result", "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
'
wsDestination.UsedRange.EntireColumn.AutoFit ' Autofit all of the columns on the DestinationSheet
'
'---------------------------------------------------------------
'
ColumnFirstBlankValueRow = wsDestination.Range(DestinationRemarksColumn & "1:" & _
DestinationRemarksColumn & wsDestination.Range("A" & _
Rows.Count).End(xlUp).Row).Find(what:="", LookAt:=xlWhole, SearchDirection:=xlNext).Row ' Locate first row in column with a blank value ... 202
'
wsDestination.Rows(ColumnFirstBlankValueRow & ":" & DestinationLastRow).Copy ' Copy 'Mismatches' rows from the DestinationSheet
wsMismatches.Range("A2").PasteSpecial Paste:=xlPasteAll ' Paste the 'Mismatches' rows to wsMismatches
Application.CutCopyMode = False ' Clear clipboard & 'marching ants' around copied range
'
wsMismatches.UsedRange.EntireColumn.AutoFit ' Autofit all of the columns on the MismatchesSheet
'
wsDestination.Rows("2:" & ColumnFirstBlankValueRow - 1).Copy ' Copy 'Matched' rows from the DestinationSheet
wsMatched.Range("A2").PasteSpecial Paste:=xlPasteAll ' Paste the 'Matched' rows to wsMatched
Application.CutCopyMode = False ' Clear clipboard & 'marching ants' around copied range
'
wsMatched.UsedRange.EntireColumn.AutoFit ' Autofit all of the columns on the MatchedSheet
'
Application.ScreenUpdating = True ' Turn ScreenUpdating back on
End Sub
Sub GetDataFromDataSheet(DataWorkSheet As String)
'
Dim ArrayColumn As Long, ArrayRow As Long
Dim CorrectedColumn As Long
Dim DataLastColumn As String, DataLastRow As Long, DestinationStartRow As Long
Dim CorrectedDataArray As Variant
Dim DataSheetArray As Variant
'
DataLastRow = Sheets(DataWorkSheet).Range("B" & _
Sheets(DataWorkSheet).Rows.Count).End(xlUp).Row ' Get last row of the Data sheet column B
'
DataLastColumn = Split(Cells(1, (Sheets(DataWorkSheet).Cells.Find("*", _
, xlFormulas, , xlByColumns, xlPrevious).Column)).Address, "$")(1) ' Get last column letter of the Data sheet
'
Sheets(DataWorkSheet).Range("C2:C" & DataLastRow) = "As Per " & DataWorkSheet ' Copy 'AS PER ' & sheet name to Column C of the sheet
'
DataSheetArray = Sheets(DataWorkSheet).Range("A2:" & _
DataLastColumn & DataLastRow) ' Load Data from Data sheet to 2D 1 based DataSheetArray
'
ReDim CorrectedDataArray(1 To UBound(DataSheetArray, 1), _
1 To UBound(DataSheetArray, 2) - 2) ' Set the number of rows & columns for the CorrectedDataArray
'
CorrectedColumn = 0 ' Initialize CorrectedColumn
'
For ArrayRow = 1 To UBound(DataSheetArray, 1) ' Loop through the rows of DataSheetArray
For ArrayColumn = 2 To UBound(DataSheetArray, 2) ' Loop through the columns of DataSheetArray
Select Case ArrayColumn
Case 3: ' Skip this Column
Case Else
CorrectedColumn = CorrectedColumn + 1 ' Increment CorrectedColumn
'
CorrectedDataArray(ArrayRow, CorrectedColumn) = _
DataSheetArray(ArrayRow, ArrayColumn) ' Save DataSheetArray data into CorrectedDataArray
End Select
Next ' Loop back
'
CorrectedColumn = 0 ' Reset CorrectedColumn
Next ' Loop back
'
DestinationStartRow = DestinationLastRow + 1 ' Save DestinationLastRow + 1 into DestinationStartRow
'
wsDestination.Range("B" & DestinationStartRow).Resize(UBound(CorrectedDataArray, _
1), UBound(CorrectedDataArray, 2)) = CorrectedDataArray ' Display Results to destination sheet
'
DestinationLastRow = wsDestination.Range("B" & _
wsDestination.Rows.Count).End(xlUp).Row ' Recalculate last row used in column B of the destination sheeet
'
wsDestination.Range("O" & DestinationStartRow & ":O" & _
DestinationLastRow) = DataSheetArray(1, 3) ' Copy 'As Per ????' to Column O
'
wsDestination.Range("A" & DestinationStartRow & _
":A" & DestinationLastRow).Formula = "=Row() - 1" ' Use formula to set row #s
wsDestination.Range("A" & DestinationStartRow & ":A" & DestinationLastRow).Copy ' Copy formula range into memory
wsDestination.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 Sub
Sub SortColumnAndApplyFormulas(HeaderTitle As String)
'
Dim ColumnFirstZeroValueRow As Long
Dim DSCol As String ' DestinationSortColumn
Dim FormulaReplacementString1 As String
'
DSCol = Split(Cells(1, wsDestination.Range("1:1").Find(HeaderTitle).Column).Address, "$")(1) ' Find Column letter of the HeaderTitle we are looking for
'
' RANGE SORTER ... Least important column to most important column 7
wsDestination.Range("A2:O" & DestinationLastRow). _
Sort Key1:=wsDestination.Range(DSCol & "2"), Order1:=xlDescending, Header:=xlNo ' Sort HeaderTitle Column highest to lowest
'
ColumnFirstZeroValueRow = wsDestination.Range(DSCol & "1:" & DSCol & wsDestination.Range("A" & _
Rows.Count).End(xlUp).Row).Find(what:=0, LookAt:=xlWhole, SearchDirection:=xlNext).Row ' Locate first row in column with a zero value
'
FormulaReplacementString1 = "MIN(SUM(IF(($C$2:$C$20000=C2)*(ABS(" & DSCol & "2-$" & DSCol & "$2:$" & _
DSCol & "$20000)<=1)*($B$2:$B$20000=""PORTAL""),1,0)),SUM(IF(($C$2:$C$20000=C2)*(ABS(" & _
DSCol & "2-$" & DSCol & "$2:$" & DSCol & "$20000)<=1)*($B$2:$B$20000=""TALLY""),1,0)))" ' Additional string to insert into formula
'
With wsDestination.Range(DestinationRemarksColumn & "2")
.FormulaArray = "=IFERROR(IF(ROW(B2)<=SMALL(IF((ABS(" & DSCol & "2-$" & DSCol & "$2:$" & DSCol & _
"$20000)<=1)*(C2=$C$2:$C$20000)*(B2=$B$2:$B$20000),ROW($A$2:$A$20000),""""),xxxxxx)" & _
",""Matched"",NA()),NA())" ' Formula to insert into 'Remarks' column
.Replace "xxxxxx", FormulaReplacementString1, xlPart ' Insert additional string into formula
End With
'
wsDestination.Range(DestinationRemarksColumn & "2").AutoFill wsDestination.Range(DestinationRemarksColumn & _
"2:" & DestinationRemarksColumn & ColumnFirstZeroValueRow - 1) ' Drag the formula down till zero value is found
'
wsDestination.Range(DestinationRemarksColumn & "2:" & DestinationRemarksColumn & _
ColumnFirstZeroValueRow - 1).Copy ' Copy formula range into memory
wsDestination.Range(DestinationRemarksColumn & "2:" & DestinationRemarksColumn & _
ColumnFirstZeroValueRow - 1).PasteSpecial xlPasteValues ' Paste just the vales back to range
Application.CutCopyMode = False ' Clear clipboard & 'marching ants' around copied range
End Sub
