VBA code

RAJESH1960

Well-known Member
Joined
Mar 26, 2020
Messages
856
Office Version
  1. 2019
Platform
  1. Windows
Hello everyone

This is a sample list of entries in excel. Some entries are multiple in nature and some are single. I have to separate the multiple entries and single entries and paste them in two different sheets. This I have been doing manually till now. I want to write a code for the same and make it easier and less time consuming. When I record a macro, it works fine for this data only. But when the data contains different number of entries the macro doesn’t work. Here, I am sharing the code of the recorded macro. There are 2 sheets. One is the original copy of data sent and one that is after the code was run. Hope someone understands it and makes it work for different data also which may range between 1000 to 1500 rows.
Original data format
code test for cleaning data.xlsm
ABCDEFGHI
1Test Multiple Ledgers
2Kotak Bank Book
3
4
51-Apr-2021 to 12-Jul-2021
6DateParticularsVch TypeVch No.DebitCredit
701-04-2021CrOpening Balance15000.00
830-06-2021Cr(as per details)Receipt14040.00
9Sunday1015.00 Cr
10Monday2025.00 Cr
11Tuesday1000.50 Cr
12Round Off0.50 Dr
1302-07-2021CrCashContra12000.00
1403-07-2021DrCashContra225000.00
1504-07-2021Dr(as per details)Payment11001.00
16January100.00 Dr
17February200.00 Dr
18March300.00 Dr
19April400.00 Dr
20Round Off1.00 Dr
2105-07-2021Cr(as per details)Receipt34040.00
22Sunday1015.00 Cr
23Monday2025.00 Cr
24Tuesday1000.50 Cr
25Round Off0.50 Dr
2607-07-2021CrCashContra32000.00
2708-07-2021DrCashContra425000.00
2809-07-2021Dr(as per details)Payment21001.00
29January100.00 Dr
30February200.00 Dr
31March300.00 Dr
32April400.00 Dr
33Round Off1.00 Dr
3412-07-2021DrJanuaryPayment3100.00
3527080.0052102.00
36CrClosing Balance25022.00
3752102.0052102.00
38
Bank


Result after code is run
code test for cleaning data.xlsm
ABCDEFG
1LineDateVch TypeVch No.ParticularsDebitCredit
2602-07-2021Contra1Cash2000.00
3703-07-2021Contra2Cash25000.00
41907-07-2021Contra3Cash2000.00
52008-07-2021Contra4Cash25000.00
62712-07-2021Payment3January100.00
7
8130-06-2021Receipt1(as per details)4040.00
92Sunday1015.00
103Monday2025.00
114Tuesday1000.50
125Round Off0.50 Dr
13804-07-2021Payment1(as per details)1001.00
149January100.00 Dr
1510February200.00 Dr
1611March300.00 Dr
1712April400.00 Dr
1813Round Off1.00 Dr
191405-07-2021Receipt3(as per details)4040.00
2015Sunday1015.00
2116Monday2025.00
2217Tuesday1000.50
2318Round Off0.50 Dr
242109-07-2021Payment2(as per details)1001.00
2522January100.00 Dr
2623February200.00 Dr
2724March300.00 Dr
2825April400.00 Dr
2926Round Off1.00 Dr
30
After running code


This is the code
Option Explicit

Sub Rajesh()
Dim Fnd As Range

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 .Rows("1:" & Fnd.Row - 1).Delete
End With
'the heading of B1 is shifted to C1
Range("B1").Select
Selection.Cut Destination:=Range("C1")
'the column B is deleted
Columns("B:B").Select
Selection.Delete Shift:=xlToLeft
'columns C & D are deleted
Columns("C:D").Select
Selection.Delete Shift:=xlToLeft
'after deleting the columns C and D are cut and inserted after date column
Columns("C:D").Select
Selection.Cut
Columns("B:B").Select
Selection.Insert Shift:=xlToRight
'the font of the cells of the whole sheet are changed to regular
Cells.Select
Selection.Font.Bold = True
Selection.Font.Bold = False
'the columns F and G are converted to number with 2 decimals
Columns("F:G").Select
Selection.NumberFormat = "0.00"
'the row with the opening balance is deleted
Rows("2:2").Select
Selection.Delete Shift:=xlUp
'a new column is inserted before column A and are numbered from 1 to the last row with value
Columns("A:A").Select
Selection.Insert Shift:=xlToRight
Range("A1").Select
ActiveCell.FormulaR1C1 = "Line"
Range("A2").Select
ActiveCell.FormulaR1C1 = "1"
Range("A3").Select
ActiveCell.FormulaR1C1 = "2"
Range("A2:A3").Select
Selection.AutoFill Destination:=Range("A2:A31")
Range("A2:A31").Select
'the last 3 rows are deleted as they are not required in every case
Rows("29:31").Select
Selection.Delete Shift:=xlUp
'the multiple and single ledgers are seperated with these workings
Range("A1").Select
ActiveWorkbook.Worksheets("Bank").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Bank").Sort.SortFields.Add2 Key:=Range("B2:B28"), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Bank").Sort
.SetRange Range("A1:G28")
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
'as the sheet is formatted the blank cells below the date, vch Type and Vch no are cleared
Range("B11:D11").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Clear
Range("A11:G28").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 65535
.TintAndShade = 0
.PatternTintAndShade = 0
End With
'the rows containing blank cells in columns B C and D, are colored
Range("B10").Select
ActiveWorkbook.Worksheets("Bank").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Bank").Sort.SortFields.Add2 Key:=Range("E2:E28"), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Bank").Sort
.SetRange Range("A1:G28")
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
ActiveWindow.SmallScroll Down:=-18
'the cells containing (as per details) are colored in all the cases
Range("A2:G5").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 65535
.TintAndShade = 0
.PatternTintAndShade = 0
End With
'the data is displayed back to the original position
Range("A2").Select
ActiveWorkbook.Worksheets("Bank").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Bank").Sort.SortFields.Add2 Key:=Range("A2:A28"), _
SortOn:=xlSortOnCellColor, Order:=xlAscending, DataOption:=xlSortNormal
ActiveWorkbook.Worksheets("Bank").Sort.SortFields.Add2 Key:=Range("A2:A28"), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Bank").Sort
.SetRange Range("A1:G28")
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
'the single and multiple entries are seperated
Rows("7:7").Select
Selection.Insert Shift:=xlDown
Range("B2").Select

End Sub
 

Excel Facts

Bring active cell back into view
Start at A1 and select to A9999 while writing a formula, you can't see A1 anymore. Press Ctrl+Backspace to bring active cell into view.

DanteAmor

Well-known Member
Joined
Dec 3, 2018
Messages
14,152
Office Version
  1. 2007
Platform
  1. Windows
I checked the code to separate multiple entries and individual entries, if the conditions are met: column C different from "(as per details)" and column F different from blank.
That way you don't need to sort the data repeatedly.

The result will be in the sheet called "after"


VBA Code:
Sub separate_multiple_entries()
  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("After")
    .Cells.ClearContents
    .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
  End With
End Sub
 

RAJESH1960

Well-known Member
Joined
Mar 26, 2020
Messages
856
Office Version
  1. 2019
Platform
  1. Windows
I checked the code to separate multiple entries and individual entries, if the conditions are met: column C different from "(as per details)" and column F different from blank.
That way you don't need to sort the data repeatedly.

The result will be in the sheet called "after"


VBA Code:
Sub separate_multiple_entries()
  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("After")
    .Cells.ClearContents
    .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
  End With
End Sub
DanteAmor, Thank you so much for your time. There is only one sheet "Bank". There is no other sheet. "after running code" is just for reference as to how it will display after the code is run. I am getting an error. After I replaced "after" with "Bank". I got my solution. Only the line numbers display is in different formats, some are text and some are date. The format of some of the cells is also different, lines 1,2 and 4. Please help me to rectify that. Till then I will check the code with different datas.
test code.xlsm
ABCDEFG
1LineDateVch TypeVch No.ParticularsDebitCredit
267/2/2021Contra1Cash2000.00
377/3/2021Contra2Cash25000.00
4197/7/2021Contra3Cash2000.00
5207/8/2021Contra4Cash25000.00
6277/12/2021Payment3January100.00
7
801-01-19006/30/2021Receipt1(as per details)4040.00
92Sunday1015.00
103Monday2025.00
114Tuesday1000.50
125Round Off0.50
1308-01-19007/4/2021Payment1(as per details)1001.00
1409-01-1900January100.00
1510-01-1900February200.00
1611March300.00
1712April400.00
1813Round Off1.00
19147/5/2021Receipt3(as per details)4040.00
2015Sunday1015.00
2116-01-1900Monday2025.00
2217Tuesday1000.50
2318Round Off0.50
24217/9/2021Payment2(as per details)1001.00
2522January100.00
2623-01-1900February200.00
2724-01-1900March300.00
2825-01-1900April400.00
2926Round Off1.00
Bank

One more thing. I need the date in this format - dd-mm-yyyy
 

RAJESH1960

Well-known Member
Joined
Mar 26, 2020
Messages
856
Office Version
  1. 2019
Platform
  1. Windows
DanteAmor, Thank you so much for your time. There is only one sheet "Bank". There is no other sheet. "after running code" is just for reference as to how it will display after the code is run. I am getting an error. After I replaced "after" with "Bank". I got my solution. Only the line numbers display is in different formats, some are text and some are date. The format of some of the cells is also different, lines 1,2 and 4. Please help me to rectify that. Till then I will check the code with different datas.
test code.xlsm
ABCDEFG
1LineDateVch TypeVch No.ParticularsDebitCredit
267/2/2021Contra1Cash2000.00
377/3/2021Contra2Cash25000.00
4197/7/2021Contra3Cash2000.00
5207/8/2021Contra4Cash25000.00
6277/12/2021Payment3January100.00
7
801-01-19006/30/2021Receipt1(as per details)4040.00
92Sunday1015.00
103Monday2025.00
114Tuesday1000.50
125Round Off0.50
1308-01-19007/4/2021Payment1(as per details)1001.00
1409-01-1900January100.00
1510-01-1900February200.00
1611March300.00
1712April400.00
1813Round Off1.00
19147/5/2021Receipt3(as per details)4040.00
2015Sunday1015.00
2116-01-1900Monday2025.00
2217Tuesday1000.50
2318Round Off0.50
24217/9/2021Payment2(as per details)1001.00
2522January100.00
2623-01-1900February200.00
2724-01-1900March300.00
2825-01-1900April400.00
2926Round Off1.00
Bank

One more thing. I need the date in this format - dd-mm-yyyy
As mentioned in my code, the sheet is derived from another software and hence all the cells are formatted. So, I added that in my code to clear the formatted cells to blank. Once the cells are cleared of all formats the cells will get the desired format in Line, date, etc.,

'as the sheet is formatted the blank cells below the date, vch Type and Vch no are cleared
Range("B11:D11").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Clear
 

RAJESH1960

Well-known Member
Joined
Mar 26, 2020
Messages
856
Office Version
  1. 2019
Platform
  1. Windows

ADVERTISEMENT

I have added a macro to your code to get the derived result.
Sub separate_multiple_entries()
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.ClearContents
.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
Cells.Select
Cells.EntireColumn.AutoFit
Selection.Font.Bold = False
Selection.Font.Bold = True
Selection.Font.Bold = False
Selection.Font.Size = 11
With Selection.Font
.Name = "Calibri"
.Size = 11
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ThemeColor = xlThemeColorLight1
.TintAndShade = 0
.ThemeFont = xlThemeFontMinor
End With
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
Selection.Borders(xlEdgeLeft).LineStyle = xlNone
Selection.Borders(xlEdgeTop).LineStyle = xlNone
Selection.Borders(xlEdgeBottom).LineStyle = xlNone
Selection.Borders(xlEdgeRight).LineStyle = xlNone
Selection.Borders(xlInsideVertical).LineStyle = xlNone
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
With Selection
.HorizontalAlignment = xlLeft
.WrapText = False
.Orientation = 0
.AddIndent = False
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
With Selection
.HorizontalAlignment = xlGeneral
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = -1
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
With Selection
.HorizontalAlignment = xlLeft
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Columns("A:A").Select
Selection.NumberFormat = "General"
Range("A2").Select
End With

End Sub
Only this I was not able to change the format of the date to dd-mm-yyyy.
 

RAJESH1960

Well-known Member
Joined
Mar 26, 2020
Messages
856
Office Version
  1. 2019
Platform
  1. Windows
With ActiveSheet.UsedRange
.Value = .Value
End With

Will inserting this within the code, help to clear the formats.? I had tried it before. But where to insert the code IDK
 

DanteAmor

Well-known Member
Joined
Dec 3, 2018
Messages
14,152
Office Version
  1. 2007
Platform
  1. Windows

ADVERTISEMENT

There is only one sheet "Bank".
I understand that perfectly, you only have one sheet.
But when you are in a development stage and you try it out, it is prudent to have 2 sheets, one with the original data and the other with the result, that way you can validate the result by comparing it with the source sheet. If you delete the source data, you will not be able to make the comparison.
And another thing, if you delete the source and want to perform another test, you will have to copy the source data again and again to do more tests.
At the end of the development when you have everything under control, you can replace the data of the source sheet with the results or delete the source sheet, that part is the simplest.
_______________________________________

For the formatting of columns A and B, add the following:
VBA Code:
Columns("A:A").NumberFormat = "General"
Columns("B:B").NumberFormat = "dd-mm-yy"
_______________________________________

Note: In the future, use code tags to insert the VBA code.
 
Last edited:

RAJESH1960

Well-known Member
Joined
Mar 26, 2020
Messages
856
Office Version
  1. 2019
Platform
  1. Windows
I understand that perfectly, you only have one sheet.
But when you are in a development stage and you try it out, it is prudent to have 2 sheets, one with the original data and the other with the result, that way you can validate the result by comparing it with the source sheet. If you delete the source data, you will not be able to make the comparison.
And another thing, if you delete the source and want to perform another test, you will have to copy the source data again and again to do more tests.
At the end of the development when you have everything under control, you can replace the data of the source sheet with the results or delete the source sheet, that part is the simplest.
_______________________________________

For the formatting of columns A and B, add the following:
VBA Code:
Columns("A:A").NumberFormat = "General"
Columns("B:B").NumberFormat = "dd-mm-yy"
_______________________________________

Note: In the future, use code tags to insert the VBA code.
Very true DanteAmor. Every time I need to move the original sheet to the code sheet to compare. But that again I have to write a new code for that again. By the way, I just added your code to the old one, but I am still not getting the date format correct. It has to be dd-mm-yyyy.
Please check the sheet sent again after running the code.

DanteAmor Query to correct code.xlsm
ABCDEFG
1LineDateVch TypeVch No.ParticularsDebitCredit
267/2/2021Contra1Cash2000.00
377/3/2021Contra2Cash25000.00
4197/7/2021Contra3Cash2000.00
5207/8/2021Contra4Cash25000.00
6277/12/2021Payment3January100.00
7
816/30/2021Receipt1(as per details)4040.00
92Sunday1015.00
103Monday2025.00
114Tuesday1000.50
125Round Off0.50
1387/4/2021Payment1(as per details)1001.00
149January100.00
1510February200.00
1611March300.00
1712April400.00
1813Round Off1.00
19147/5/2021Receipt3(as per details)4040.00
2015Sunday1015.00
2116Monday2025.00
2217Tuesday1000.50
2318Round Off0.50
24217/9/2021Payment2(as per details)1001.00
2522January100.00
2623February200.00
2724March300.00
2825April400.00
2926Round Off1.00
Bank
 

DanteAmor

Well-known Member
Joined
Dec 3, 2018
Messages
14,152
Office Version
  1. 2007
Platform
  1. Windows
but I am still not getting the date format correct.
You are having problems because column B has a different format on the source sheet.
Try the following, the result on the "after" sheet, for testing purposes only. I think you should keep the original "bank" sheet.
Then if you want to delete it.
I know that the problem can be fixed if you clean the sheet "bank" with sheets ("bank").Cells.Clear, but you can try the sheet "after" and then, as I already mentioned, you pass it to the sheet "bank".

Here the improved code, even if it is done in the "after" sheet as it is free of formats, several rows could be eliminated, but I leave you the lines, so that you can do the tests.

VBA Code:
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("after")
    .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
End Sub
 
Solution

RAJESH1960

Well-known Member
Joined
Mar 26, 2020
Messages
856
Office Version
  1. 2019
Platform
  1. Windows
You are having problems because column B has a different format on the source sheet.
Try the following, the result on the "after" sheet, for testing purposes only. I think you should keep the original "bank" sheet.
Then if you want to delete it.
I know that the problem can be fixed if you clean the sheet "bank" with sheets ("bank").Cells.Clear, but you can try the sheet "after" and then, as I already mentioned, you pass it to the sheet "bank".

Here the improved code, even if it is done in the "after" sheet as it is free of formats, several rows could be eliminated, but I leave you the lines, so that you can do the tests.

VBA Code:
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("after")
    .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
End Sub
Now it is perfect. I only had to change the code at
With Sheets("after")
.Cells.Clear
to
With Sheets("Bank")
.Cells.Clear
Thank you so much DanteAmor.
 
Learn Excel from Bill Jelen

Understanding data is crucial, and the easiest place to start is with Microsoft Excel.

Forum statistics

Threads
1,151,491
Messages
5,764,681
Members
425,229
Latest member
Rashid mahmood

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top