Option Explicit
Public StartTime As Double
Sub CombineSheetsV3A() ' 0.18359375 average seconds
'
StartTime = Timer
'
Dim SheetRow As Long
Dim StartRow As Long
Dim Table1StartRow As Long
Dim LastColumnInSheet As String
Dim NewSheetName As String
Dim OriginalSourceSheet As Worksheet
Dim DestinationSheet As Worksheet
Dim ws As Worksheet
'
Application.ScreenUpdating = False ' Turn ScreenUpdating Off
'
Set OriginalSourceSheet = Worksheets("Table 1") ' <-- Set this to the sheet to use for the initial input data
NewSheetName = "SBI" ' <--- Set this to the NewSheetName
StartRow = 2 ' <--- Set this to the starting row of data of Table 2 & beyond
Table1StartRow = 4 ' <--- Set this to the starting row of data in Table 1 sheet
'
Sheets.Add(Before:=OriginalSourceSheet).Name = NewSheetName ' Add new sheet before the sheet used for the initial input
Set DestinationSheet = Sheets(NewSheetName) '
'
With OriginalSourceSheet
LastColumnInSheet = Split(Cells(1, (.Cells.Find("*", , xlFormulas, , _
xlByColumns, xlPrevious).Column)).Address, "$")(1) ' Get LastColumnInSheet
'
DestinationSheet.Range("A1:" & LastColumnInSheet & "1").Value2 = .Range("A" & _
Table1StartRow - 1 & ":" & LastColumnInSheet & Table1StartRow - 1).Value2 ' Copy Header to new sheet
'
DestinationSheet.Range("A2:" & LastColumnInSheet & .Range("A" & _
Rows.Count).End(xlUp).Row - Table1StartRow + StartRow).Value2 = .Range("A" & _
Table1StartRow & ":" & LastColumnInSheet & .Range("A" & _
Rows.Count).End(xlUp).Row).Value2 ' Copy data to DestinationSheet ... 0.00390625
End With
'
For Each ws In Worksheets ' Loop through all sheets in the workbook
If ws.Name <> NewSheetName And ws.Name <> "Table 1" And Left$(ws.Name, 5) = "Table" Then ' If we find a sheet that we want then ...
'
DestinationSheet.Range("A" & DestinationSheet.Range("A" & Rows.Count).End(xlUp).Row + 1 & _
":" & LastColumnInSheet & DestinationSheet.Range("A" & _
Rows.Count).End(xlUp).Row + ws.Range("A" & Rows.Count).End(xlUp).Row - 1).Value2 = _
ws.Range("A2:" & LastColumnInSheet & ws.Range("A" & Rows.Count).End(xlUp).Row).Value2 ' Copy the data to the DestinationSheet ... 0.00390625
End If
Next ' Loop back
'
With DestinationSheet
.Columns("A:B").Replace What:="" & Chr(10) & "", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByColumns, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False ' Remove LineFeeds from Dates in Columns A:B
'
.Range("A2", .Cells(.Rows.Count, "A").End(xlUp)).SpecialCells(xlCellTypeConstants, _
xlTextValues).EntireRow.Delete ' If cell in Column A is text, delete the row
'
.Columns("A:B").NumberFormat = "dd-mm-yyyy" ' Set Date format of new sheet Columns A:B to "dd-mm-yyyy"
'
.Columns("E:F").Replace ",", "", xlPart
'
With .Range("C" & StartRow & ":C" & .Range("A" & Rows.Count).End(xlUp).Row)
.Value = Evaluate("IF(" & .Address & "="""","""",TRIM(" & .Address & "))")
End With
End With
'
With DestinationSheet.UsedRange ' Format all Columns on the new sheet
.Columns.Font.Name = "Calibri"
.Columns.Font.Size = 11
.WrapText = False
.Columns.AutoFit
.Rows.AutoFit
End With
'
Application.ScreenUpdating = True ' Turn ScreenUpdating back on
'
BankCleanDataV4
'
MsgBox "Complete."
End Sub
Sub BankCleanDataV4()
'
'solved by JohnnyL 27-06-2022
'
Dim ArrayRow As Long, OutputRow As Long
Dim BlankRows As Long, CurrentRow As Long
Dim SheetRow As Long, StartRow As Long
'
Dim OutputClosingBalanceColumnNumber As Long, OutputDateColumnNumber As Long
Dim OutputDepositAmountColumnNumber As Long, OutputNarrationColumnNumber As Long
Dim OutputLineColumnNumber As Long, OutputTallyLedgerColumnNumber As Long
Dim OutputVoucherTypeColumnNumber As Long, OutputWithdrawalAmountColumnNumber As Long
'
Dim SourceChqRefColumnNumber As Long, SourceClosingBalanceColumnNumber As Long
Dim SourceConCatColumnNumber As Long, SourceDateColumnNumber As Long
Dim SourceDepositAmountColumnNumber As Long
Dim SourceNarrationColumnNumber As Long, SourceWithdrawalAmountColumn As Long
'
Dim OutputCheckColumnLetter As String, OutputClosingBalanceColumnLetter As String
Dim OutputDepositAmountColumnLetter As String, OutputWithdrawalAmountColumnLetter As String
Dim SourceConCatColumnLetter As String, SourceDateColumnLetter As String
Dim OutputLastColumnLetterInSheet As String
Dim OutputEmptyColumnLetter As String
Dim NewSheetName As String
Dim HeaderArray As Variant, SourceArray As Variant, OutputArray() As Variant
Dim SourceSheet As Worksheet, OutputSheet As Worksheet
'
Set SourceSheet = Worksheets("SBI") ' <-- Set this to the sheet to use for the input data
'
OutputCheckColumnLetter = "J" ' <--- Set this to OutputCheckColumnLetter
SourceConCatColumnLetter = "B" ' <--- Set this to the source column that needs Concat function
SourceDateColumnLetter = "A" ' <--- Set this to source column of Dates
NewSheetName = "Bank" ' <--- Set this to the NewSheetName
StartRow = 2 ' <--- Set this to the starting row of data
'
OutputClosingBalanceColumnNumber = 9 ' <--- Set this to the OutputClosingBalanceColumnNumber
OutputDateColumnNumber = 2 ' <--- Set this to the OutputDateColumnNumber
OutputDepositAmountColumnNumber = 7 ' <--- Set this to the OutputDepositAmountColumnNumber
OutputLineColumnNumber = 1 ' <--- Set this to the OutputLineColumnNumber
OutputNarrationColumnNumber = 8 ' <--- Set this to the OutputNarrationColumnNumber
OutputTallyLedgerColumnNumber = 5 ' <--- Set this to the OutputTallyLedgerColumnNumber
OutputVoucherTypeColumnNumber = 3 ' <--- Set this to the OutputVoucherTypeColumnNumber
OutputWithdrawalAmountColumnNumber = 6 ' <--- Set this to the OutputWithdrawalAmountColumn
'
SourceChqRefColumnNumber = 4 '3 ' <--- Set this to the SourceChqRefColumnNumber
SourceClosingBalanceColumnNumber = 7 ' <--- Set this to the SourceClosingBalanceColumnNumber
SourceDateColumnNumber = 1 ' <--- Set this to the SourceDateColumnNumber
SourceDepositAmountColumnNumber = 6 ' <--- Set this to the SourceDepositAmountColumnNumber
SourceNarrationColumnNumber = 3 '2 ' <--- Set this to the SourceNarrationColumnNumber
SourceWithdrawalAmountColumn = 5 ' <--- Set this to the SourceWithdrawalAmountColumn
'
HeaderArray = Array("Line", "Date", "Voucher Type", "Voucher No.", _
"Tally Ledger Name", "Debit", "Credit", _
"Description", "Balance", "Check") ' <--- Set Array of headers to write to the created sheet
'
Application.ScreenUpdating = False ' Turn ScreenUpdating off
'
Sheets.Add(After:=SourceSheet).Name = NewSheetName ' Add new sheet after the sheet used for the input
Set OutputSheet = Worksheets(NewSheetName) ' Set OutputSheet to the sheet to use for the output data
'
SourceSheet.UsedRange.Copy OutputSheet.Range("A1") ' Copy SourceSheet to OutputSheet
'
SourceConCatColumnNumber = OutputSheet.Range(SourceConCatColumnLetter & 1).Column ' Convert SourceConCatColumnLetter to SourceConCatColumnNumber
SourceDateColumnNumber = OutputSheet.Range(SourceDateColumnLetter & 1).Column ' Convert SourceDateColumnLetter to SourceDateColumnNumber
'
OutputLastColumnLetterInSheet = Split(OutputSheet.Cells(1, (OutputSheet.Cells.Find("*", _
, xlFormulas, , xlByColumns, xlPrevious).Column)).Address, "$")(1) ' Get last Column Letter used in Output sheet
'
BlankRows = 0 ' Initialize BlankRows
OutputRow = 0 ' Initialize OutputRow
'
'-----------------------------------------------------------------------------------
'
SourceArray = OutputSheet.Range("A" & StartRow & ":" & OutputLastColumnLetterInSheet & _
OutputSheet.Range(SourceConCatColumnLetter & Rows.Count).End(xlUp).Row).Value2 ' Save data from sheet into SourceArray
ReDim OutputArray(1 To UBound(SourceArray, 1), 1 To 1) ' Set OutputArray to same # of rows as the SourceArray
'
For ArrayRow = 1 To UBound(SourceArray, 1) ' Loop through the rows of the SourceArray
If SourceArray(ArrayRow, SourceDateColumnNumber) <> vbNullString Then ' If Date is not blank then ...
OutputRow = OutputRow + 1 ' Increment OutputRow
'
CurrentRow = OutputRow + BlankRows ' Get total of OutputRow + BlankRows and save to CurrentRow
OutputArray(CurrentRow, 1) = SourceArray(ArrayRow, SourceConCatColumnNumber) ' Save Concat word to OutputArray(CurrentRow, 1)
Else ' Else ...
BlankRows = BlankRows + 1 ' Increment BlankRows
OutputArray(CurrentRow, 1) = OutputArray(CurrentRow, 1) & _
" " & SourceArray(ArrayRow, SourceConCatColumnNumber) ' Append a space & next Concat word to OutputArray(CurrentRow, 1)
End If
Next ' Loop back
'
'-----------------------------------------------------------------------------------
'
With OutputSheet
.Range(SourceConCatColumnLetter & StartRow & ":" & SourceConCatColumnLetter & _
.Range(SourceConCatColumnLetter & _
.Rows.Count).End(xlUp).Row).Value2 = OutputArray ' Write Concat column back to new sheet
'
On Error Resume Next ' Ignore error in next line if no blank rows were found to delete
.Columns("A").SpecialCells(xlBlanks).EntireRow.Delete ' If cell in used range of column A is blank then delete that row
'
.Range("A2", .Cells(.Rows.Count, "A").End(xlUp)).SpecialCells(xlCellTypeConstants, _
xlTextValues).EntireRow.Delete ' If cell in Column A is text, delete the row
On Error GoTo 0
End With
'
'-----------------------------------------------------------------------------------
'
SourceArray = OutputSheet.Range("A" & StartRow & ":" & OutputLastColumnLetterInSheet & _
OutputSheet.Range(SourceDateColumnLetter & Rows.Count).End(xlUp).Row) ' Load Data from new sheet into SourceArray
ReDim OutputArray(1 To UBound(SourceArray, 1), 1 To UBound(HeaderArray) + 1) ' Set # of rows & columns for the OutputArray
'
OutputSheet.UsedRange.Clear ' Erase the OutputSheet
'
OutputRow = 0 ' Reset OutputRow
'
For ArrayRow = 1 To UBound(SourceArray, 1) ' Loop through the rows of data in the SourceArray
OutputRow = OutputRow + 1
'
OutputArray(ArrayRow, OutputLineColumnNumber) = ArrayRow ' Save the Line # to Column 1 of OutputArray
OutputArray(ArrayRow, OutputDateColumnNumber) = _
SourceArray(ArrayRow, SourceDateColumnNumber) ' Save Date to Column 2 of OutputArray
'
' voucher type
If SourceArray(ArrayRow, SourceWithdrawalAmountColumn) <> 0 Then ' If Withdrawal Amt. <> 0 then ...
OutputArray(ArrayRow, OutputVoucherTypeColumnNumber) = "Payment" ' Put "Payment" in Column 3 of OutputArray
ElseIf SourceArray(ArrayRow, SourceDepositAmountColumnNumber) <> 0 Then ' Else if Deposit Amt. <> 0 then ...
OutputArray(ArrayRow, OutputVoucherTypeColumnNumber) = "Receipt" ' Put "Receipt" in Column 3 of OutputArray
End If
'
'voucher #
' ???
'
'
'Tally Ledger Name
' ???
OutputArray(ArrayRow, OutputTallyLedgerColumnNumber) = "Suspense in Bank" ' Not sure if this is supposed to be hard coded?
'
OutputArray(ArrayRow, OutputWithdrawalAmountColumnNumber) = _
SourceArray(ArrayRow, SourceWithdrawalAmountColumn) ' Save Withdrawal Amount to Column 6 of OutputArray
OutputArray(ArrayRow, OutputDepositAmountColumnNumber) = _
SourceArray(ArrayRow, SourceDepositAmountColumnNumber) ' Save Deposit Amount to Column 7 of OutputArray
'
If SourceArray(ArrayRow, SourceChqRefColumnNumber) <> 0 Then ' If Chq./Ref.No. <> 0 then ...
OutputArray(ArrayRow, OutputNarrationColumnNumber) = SourceArray(ArrayRow, _
SourceNarrationColumnNumber) & " Chq./Ref.No. " & _
SourceArray(ArrayRow, SourceChqRefColumnNumber) ' Save Narration & Chq./Ref.No. to Column 8 of OutputArray
Else ' Else ...
OutputArray(ArrayRow, OutputNarrationColumnNumber) = _
SourceArray(ArrayRow, SourceNarrationColumnNumber) ' Save Narration to Column 8 of OutputArray
End If
'
OutputArray(ArrayRow, OutputClosingBalanceColumnNumber) = _
SourceArray(ArrayRow, SourceClosingBalanceColumnNumber) ' Save Closing Balance to Column 9 of OutputArray
Next ' Loop back
'
'-----------------------------------------------------------------------------------
'
With OutputSheet
.Range("A1").Resize(, UBound(HeaderArray) + 1) = HeaderArray ' Write the array of headers to first row of new sheet
.Range("A2").Resize(UBound(OutputArray, 1), UBound(OutputArray, 2)) = OutputArray ' Display OutputArray to new sheet starting on row 2
'
OutputLastColumnLetterInSheet = Split(.Cells(1, (.Cells.Find("*", _
, xlFormulas, , xlByColumns, xlPrevious).Column)).Address, "$")(1) ' Get last Column Letter used in Output sheet
'
.Columns(OutputDateColumnNumber).NumberFormat = "dd-mm-yyyy" ' Set Date format of new sheet Column B to "dd-mm-yyyy"
'
OutputClosingBalanceColumnLetter = Split(.Cells(1, _
OutputClosingBalanceColumnNumber).Address, "$")(1) ' Convert OutputClosingBalanceColumnNumber to OutputClosingBalanceColumnLetter
OutputDepositAmountColumnLetter = Split(.Cells(1, _
OutputDepositAmountColumnNumber).Address, "$")(1) ' Convert OutputDepositAmountColumnNumber to OutputDepositAmountColumnLetter
OutputWithdrawalAmountColumnLetter = Split(.Cells(1, _
OutputWithdrawalAmountColumnNumber).Address, "$")(1) ' Convert OutputWithdrawalAmountColumnNumber to OutputWithdrawalAmountColumnLetter
'
With .Columns(OutputWithdrawalAmountColumnLetter & ":" & OutputDepositAmountColumnLetter)
.NumberFormat = "0.00" ' Set NumberFormat of Columns F:G on new sheet to 2 decimal places
.HorizontalAlignment = xlRight
.VerticalAlignment = xlCenter
End With
'
.Range(OutputCheckColumnLetter & StartRow).Formula = "=RC[-1]" ' Set initial value of 'Check' column (J2)
.Range(OutputCheckColumnLetter & StartRow + 1 & ":" & _
OutputCheckColumnLetter & .Range("A" & _
.Rows.Count).End(xlUp).Row).Formula = "=R[-1]C+RC[-3]-RC[-4]" ' Write rest of formulas to 'Check' column (J3 to last row)
'
OutputEmptyColumnLetter = Split(.Cells(1, .Range(OutputLastColumnLetterInSheet & 1).Column _
+ 1).Address, "$")(1) ' Convert OutputLastColumnNumberInSheet +1 to OutputEmptyColumnLetter
'
.Columns(OutputCheckColumnLetter & ":" & OutputCheckColumnLetter).Copy ' Copy 'Check' Column
.Columns(OutputEmptyColumnLetter & ":" & OutputEmptyColumnLetter).PasteSpecial _
Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, _
Transpose:=False ' Paste to blank helper column
'
.Range(OutputCheckColumnLetter & StartRow & ":" & OutputCheckColumnLetter & _
.Range("A" & .Rows.Count).End(xlUp).Row).Formula = _
"=TRIM(INT(RC[1] * 100) / 100)" ' Write formulas to 'Check' column (J2 to last row)
'
.Range(OutputCheckColumnLetter & StartRow & ":" & OutputCheckColumnLetter & _
.Range("A" & Rows.Count).End(xlUp).Row).Value = _
.Range(OutputCheckColumnLetter & StartRow & ":" & _
OutputCheckColumnLetter & .Range("A" & Rows.Count).End(xlUp).Row).Value ' Remove formulas from Column J in the new sheet leaving just the values
'
.Columns(OutputEmptyColumnLetter & ":" & OutputEmptyColumnLetter).Delete ' Delete helper column
'
.Columns(OutputClosingBalanceColumnLetter & ":" & _
OutputCheckColumnLetter).NumberFormat = "#,##0.00" ' Format Columns I & J to commas & 2 decimal places
'
With .UsedRange ' Format all Columns on the new sheet
.Columns.Font.Name = "Calibri"
.Columns.Font.Size = 11
.WrapText = False
.Columns.AutoFit
.Rows.AutoFit
End With
End With
'
Application.ScreenUpdating = True ' Turn ScreenUpdating back on
'
Debug.Print "Time to Complete = " & Timer - StartTime & " Seconds." ' Display Elapsed time to Immediate window (CTRL+G)
'
If Trim(OutputSheet.Range(OutputClosingBalanceColumnLetter & OutputSheet.Range("A" & _
Rows.Count).End(xlUp).Row)) = Trim(Int(OutputSheet.Range(OutputCheckColumnLetter & _
OutputSheet.Range("A" & Rows.Count).End(xlUp).Row) * 100) / 100) Then ' If last used cell in Column I = last used cell in Column J then ...
MsgBox "Data cleaned & Matched Sccessfully" ' Display Matched message
Else ' Else ...
MsgBox "Mismatched. Check if any row is missed to enter" ' Display Mismatched message
End If
End Sub
It is perfect now. Thanks JohnnyL.
