Option Explicit
Dim DestinationLastRow As Long
Dim DestinationRemarksColumn As String
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
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 = "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
'
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")
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", "Narration", "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:O1").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:O1").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:O1").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:O1").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:O1").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:O1").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").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, 15) = "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
'
.Range("N2:N" & DestinationLastRow).Formula = "=$C$1 & "" "" & C2" & _
" & "" "" & $D$1 & "" "" & D2 & "" "" & $E$1 & "" "" & E2" & _
" & "" "" & $F$1 & "" "" & F2 & "" "" & $K$1" & _
" & "" "" & K2 & "" "" & $M$1 & "" "" & TEXT(M2,""DD-MM-YYYY"")" ' Copy Narration Formula to Column N
'
.Range("N2:N" & DestinationLastRow).Copy ' Copy formula range into memory
.Range("N2:N" & DestinationLastRow).PasteSpecial xlPasteValues ' Paste just the vales back to range
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("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
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
End If
Next ' Loop back
End With
'
' RANGE SORTER ... Most important column to least important column 3,6,2
With wsDestination
.Range("A2:O" & .Range("B" & Rows.Count).End(xlUp).Row).Sort _
Key1:=.Range("C2"), Order1:=xlAscending, _
Key2:=.Range("F2"), Order1:=xlAscending, _
Key3:=.Range("B2"), Order1:=xlAscending, Header:=xlNo ' Sort the destination sheet by various columns
End With
'
' RANGE SORTER ... Most important column to least important column 3,6,2
With wsMatched
.Range("A2:O" & .Range("B" & Rows.Count).End(xlUp).Row).Sort _
Key1:=.Range("C2"), Order1:=xlAscending, _
Key2:=.Range("F2"), Order1:=xlAscending, _
Key3:=.Range("B2"), Order1:=xlAscending, Header:=xlNo ' Sort the Matched sheet by various columns
.UsedRange.EntireColumn.AutoFit ' Autofit all of the columns on the MatchedSheet
End With
'
' RANGE SORTER ... Most important column to least important column 3,6,2
With wsMismatches
.Range("A2:O" & .Range("B" & Rows.Count).End(xlUp).Row).Sort _
Key1:=.Range("C2"), Order1:=xlAscending, _
Key2:=.Range("F2"), 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
'
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
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("B" & .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("O" & DestinationStartRow & ":O" & DestinationLastRow) = "As per " & DataWorkSheet ' Copy 'As Per ' & sheet name to Column O
'
.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
Sub SortColumnAndApplyFormulas(HeaderTitle As String)
'
Dim ColumnFirstZeroValueRow As Long
Dim LastRow As Long
Dim DSCol As String ' DestinationSortColumn
Dim IfReplacementString1 As String, IfReplacementString2 As String
Dim SecondIfReplacementString1 As String
Dim MultiplyReplacementString1 As String, MultiplyReplacementString2 As String, MultiplyReplacementString3 As String
Dim MultiplyReplacementString4 As String, MultiplyReplacementString5 As String
'
With wsDestination
LastRow = .Range("A" & .Rows.Count).End(xlUp).Row
DSCol = Split(Cells(1, .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
.Range("A2:O" & DestinationLastRow).Sort Key1:=.Range(DSCol & "2"), _
Order1:=xlDescending, Header:=xlNo ' Sort HeaderTitle Column highest to lowest
'
ColumnFirstZeroValueRow = .Range(DSCol & "1:" & DSCol & .Range("A" & _
Rows.Count).End(xlUp).Row).Find(what:=0, LookAt:=xlWhole, SearchDirection:=xlNext).Row ' Locate first row in column with a zero value
'
' Replacement strings to insert into formula
SecondIfReplacementString1 = "IF(SUM((ABS(" & DSCol & "2-$" & DSCol & "$2:$" & DSCol & _
"$" & LastRow & ")<=1)*99991*99993)>SUM((ABS(" & DSCol & "2-$" & DSCol & "$2:$" & _
DSCol & "$" & LastRow & ")<=1)*99991*99992), B9999)"
IfReplacementString1 = "IF(SUM((ABS(" & DSCol & "2-$" & DSCol & "$2:$" & DSCol & _
"2)<=1)*99994*99995)<= SUM((ABS(" & DSCol & "2-$" & DSCol & "$2:$" & DSCol & _
"$" & LastRow & ")<=1)*99991*99993), ""Matched"", ""Not Found"")"
IfReplacementString2 = "IF(SUM((ABS(" & DSCol & "2-$" & DSCol & "$2:$" & DSCol & _
"2)<=1)*99994*99995)<= SUM((ABS(" & DSCol & "2-$" & DSCol & "$2:$" & DSCol & _
"$" & LastRow & ")<=1)*99991*99992),""Matched"", ""Not Found"")"
MultiplyReplacementString1 = "(C2=$C$2:$C$" & LastRow & ")"
MultiplyReplacementString2 = "(""Portal""=$B$2:$B$" & LastRow & ")"
MultiplyReplacementString3 = "(""Tally""=$B$2:$B$" & LastRow & ")"
MultiplyReplacementString4 = "(C2=$C$2:$C2)"
MultiplyReplacementString5 = "(B2=$B$2:$B2)"
'
With .Range(DestinationRemarksColumn & "2")
.FormulaArray = "=IF(SUM((ABS(" & DSCol & "2-$" & DSCol & "$2:$" & DSCol & _
"$" & LastRow & ")<=1)*99991*99992)=SUM((ABS(" & DSCol & "2-$" & DSCol & "$2:$" & DSCol & _
"$" & LastRow & ")<=1)*99991*99993), ""Matched"", IF(SUM((ABS(" & DSCol & "2-$" & DSCol & _
"$2:$" & DSCol & "$" & LastRow & ")<=1)*99991*99992)>SUM((ABS(" & DSCol & "2-$" & DSCol & _
"$2:$" & DSCol & "$" & LastRow & ")<=1)*99991*99993), A9999, C9999))" ' Formula to insert into 'Remarks' column
'
' Variables to replace, string used to replace the variable
.Replace "C9999", SecondIfReplacementString1, xlPart
.Replace "A9999", IfReplacementString1, xlPart
.Replace "B9999", IfReplacementString2, xlPart
.Replace "99991", MultiplyReplacementString1, xlPart
.Replace "99992", MultiplyReplacementString2, xlPart
.Replace "99993", MultiplyReplacementString3, xlPart
.Replace "99994", MultiplyReplacementString4, xlPart
.Replace "99995", MultiplyReplacementString5, xlPart
End With
'
.Range(DestinationRemarksColumn & "2").AutoFill .Range(DestinationRemarksColumn & _
"2:" & DestinationRemarksColumn & ColumnFirstZeroValueRow - 1) ' Drag the formula down till zero value is found
'
.Range(DestinationRemarksColumn & "2:" & DestinationRemarksColumn & _
ColumnFirstZeroValueRow - 1).Copy ' Copy formula range into memory (Clipboard)
.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 With
End Sub
I have tried with all the different available data. Will get a few more different data from the office today and check it out tonight. I will comment only after I finish checking this with different data. 
