Sub separate_multiple_entries_new()
Dim a As Variant, b As Variant, c As Variant
Dim Fnd As Range
Dim i As Long, j As Long, k As Long, ini As Long
With Sheets("Bank")
.UsedRange.UnMerge
Set Fnd = .Range("A:A").Find("Date", , , xlPart, xlByRows, xlNext, False, , False)
If Not Fnd Is Nothing And Fnd.Row > 1 Then ini = Fnd.Row + 2 Else ini = 1
a = .Range("A" & ini, .Range("I" & Rows.Count).End(3)).Value
End With
ReDim b(1 To UBound(a), 1 To 7)
ReDim c(1 To UBound(a), 1 To 7)
For i = 1 To UBound(a) - 3
If LCase(a(i, 3)) <> LCase("(as per details)") And a(i, 6) <> "" Then
j = j + 1
b(j, 1) = i 'Line
b(j, 2) = a(i, 1) 'Date
b(j, 3) = a(i, 6) 'Vch Type
b(j, 4) = a(i, 7) 'Vch No.
b(j, 5) = a(i, 3) 'Particulars
b(j, 6) = a(i, 8) 'Debit
b(j, 7) = a(i, 9) 'Credit
Else
k = k + 1
c(k, 1) = i 'Line
c(k, 2) = a(i, 1) 'Date
c(k, 3) = a(i, 6) 'Vch Type
c(k, 4) = a(i, 7) 'Vch No.
c(k, 5) = a(i, 3) 'Particulars
c(k, 6) = a(i, 8) 'Debit
c(k, 7) = a(i, 9) 'Credit
End If
Next
With Sheets("Bank")
.Cells.Clear
.Range("A1:G1").Value = Array("Line", "Date", "Vch Type", "Vch No.", "Particulars", "Debit", "Credit")
.Range("A2").Resize(j, 7).Value = b
.Range("A" & j + 3).Resize(k, 7).Value = c
.Columns("F:G").NumberFormat = "0.00"
With .Range("A" & j + 3).Resize(k, 7).Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 65535
.TintAndShade = 0
.PatternTintAndShade = 0
End With
With .Cells
.EntireColumn.AutoFit
.Borders.LineStyle = xlNone
.HorizontalAlignment = xlLeft
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
With .Font
.Bold = False
.Name = "Calibri"
.Size = 11
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ThemeColor = xlThemeColorLight1
.TintAndShade = 0
.ThemeFont = xlThemeFontMinor
End With 'font
End With 'cells
.Range("A:A").NumberFormat = "General"
.Range("B:B").NumberFormat = "dd-mm-yyyy"
End With
Dim rngReferenceRange As Range, rngToCopy As Range
Set rngReferenceRange = ActiveSheet.Range("A1").CurrentRegion 'assumes that the first data entry is in cell A1
Set rngToCopy = Cells(rngReferenceRange.Rows.Count + 2, 1).CurrentRegion 'assumes that new data ALWAYS starts one row after the blank row
rngToCopy.Copy
With Sheets("A")
.Range("A2").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
.Columns("B:B").NumberFormat = "dd-mm-yyyy"
End With
Sheets("A").Select
Columns("E:E").Select
Selection.Insert Shift:=xlToRight
Columns("G:H").Select
Selection.Insert Shift:=xlToRight
Selection.Clear
Range("G2").Select
Application.CutCopyMode = False
ActiveCell.FormulaR1C1 = "=IF(RC[2]="""","""",-RC[2])"
Range("H2").Select
Application.CutCopyMode = False
ActiveCell.FormulaR1C1 = "=IF(RC[2]="""","""",RC[2])"
Range("G2:H2").Select
Selection.AutoFill Destination:=Range("G2:H23")
Range("G2:H23").Select
Range("A2").Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlToRight)).Select
Range("A2:H23").Select
Selection.Copy
Sheets("B").Select
Range("A2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Cells.Select
Cells.EntireColumn.AutoFit
Columns("B:B").Select
Application.CutCopyMode = False
Selection.NumberFormat = "m/d/yyyy"
Columns("F:F").Select
Selection.Replace What:="(as per details)", Replacement:="Bank", LookAt:= _
xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Range("K2").Select
End Sub