VBA code

RAJESH1960 · Jul 8, 2021

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

A

B

C

D

E

F

G

H

I

1

Test Multiple Ledgers

2

Kotak Bank Book

3

4

5

1-Apr-2021 to 12-Jul-2021

6

Date

Particulars

Vch Type

Vch No.

Debit

Credit

7

01-04-2021

Cr

Opening Balance

15000.00

8

30-06-2021

Cr

(as per details)

Receipt

1

4040.00

9

Sunday

1015.00 Cr

10

Monday

2025.00 Cr

11

Tuesday

1000.50 Cr

12

Round Off

0.50 Dr

13

02-07-2021

Cr

Cash

Contra

1

2000.00

14

03-07-2021

Dr

Cash

Contra

2

25000.00

15

04-07-2021

Dr

(as per details)

Payment

1

1001.00

16

January

100.00 Dr

17

February

200.00 Dr

18

March

300.00 Dr

19

April

400.00 Dr

20

Round Off

1.00 Dr

21

05-07-2021

Cr

(as per details)

Receipt

3

4040.00

22

Sunday

1015.00 Cr

23

Monday

2025.00 Cr

24

Tuesday

1000.50 Cr

25

Round Off

0.50 Dr

26

07-07-2021

Cr

Cash

Contra

3

2000.00

27

08-07-2021

Dr

Cash

Contra

4

25000.00

28

09-07-2021

Dr

(as per details)

Payment

2

1001.00

29

January

100.00 Dr

30

February

200.00 Dr

31

March

300.00 Dr

32

April

400.00 Dr

33

Round Off

1.00 Dr

34

12-07-2021

Dr

January

Payment

3

100.00

35

27080.00

52102.00

36

Cr

Closing Balance

25022.00

37

52102.00

38

Bank

Result after code is run

code test for cleaning data.xlsm

A

B

C

D

E

F

G

1

Line

Date

Vch Type

Vch No.

Particulars

Debit

Credit

2

6

02-07-2021

Contra

1

Cash

2000.00

3

7

03-07-2021

Contra

2

Cash

25000.00

4

19

07-07-2021

Contra

3

Cash

2000.00

5

20

08-07-2021

Contra

4

Cash

25000.00

6

27

12-07-2021

Payment

3

January

100.00

7

8

1

30-06-2021

Receipt

1

(as per details)

4040.00

9

2

Sunday

1015.00

10

3

Monday

2025.00

11

4

Tuesday

1000.50

12

5

Round Off

0.50 Dr

13

8

04-07-2021

Payment

1

(as per details)

1001.00

14

9

January

100.00 Dr

15

10

February

200.00 Dr

16

11

March

300.00 Dr

17

12

April

400.00 Dr

18

13

Round Off

1.00 Dr

19

14

05-07-2021

Receipt

3

(as per details)

4040.00

20

15

Sunday

1015.00

21

16

Monday

2025.00

22

17

Tuesday

1000.50

23

18

Round Off

0.50 Dr

24

21

09-07-2021

Payment

2

(as per details)

1001.00

25

22

January

100.00 Dr

26

23

February

200.00 Dr

27

24

March

300.00 Dr

28

25

April

400.00 Dr

29

26

Round Off

1.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

DanteAmor · Jul 10, 2021

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 · Jul 10, 2021

DanteAmor said:

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

A

B

C

D

E

F

G

1

Line

Date

Vch Type

Vch No.

Particulars

Debit

Credit

2

6

7/2/2021

Contra

1

Cash

2000.00

3

7

7/3/2021

Contra

2

Cash

25000.00

4

19

7/7/2021

Contra

3

Cash

2000.00

5

20

7/8/2021

Contra

4

Cash

25000.00

6

27

7/12/2021

Payment

3

January

100.00

7

8

01-01-1900

6/30/2021

Receipt

1

(as per details)

4040.00

9

2

Sunday

1015.00

10

3

Monday

2025.00

11

4

Tuesday

1000.50

12

5

Round Off

0.50

13

08-01-1900

7/4/2021

Payment

1

(as per details)

1001.00

14

09-01-1900

January

100.00

15

10-01-1900

February

200.00

16

11

March

300.00

17

12

April

400.00

18

13

Round Off

1.00

19

14

7/5/2021

Receipt

3

(as per details)

4040.00

20

15

Sunday

1015.00

21

16-01-1900

Monday

2025.00

22

17

Tuesday

1000.50

23

18

Round Off

0.50

24

21

7/9/2021

Payment

2

(as per details)

1001.00

25

22

January

100.00

26

23-01-1900

February

200.00

27

24-01-1900

March

300.00

28

25-01-1900

April

400.00

29

26

Round Off

1.00

Bank

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

RAJESH1960 · Jul 10, 2021

RAJESH1960 said:
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
A B C D E F G
1 Line Date Vch Type Vch No. Particulars Debit Credit
2 6 7/2/2021 Contra 1 Cash 2000.00
3 7 7/3/2021 Contra 2 Cash 25000.00
4 19 7/7/2021 Contra 3 Cash 2000.00
5 20 7/8/2021 Contra 4 Cash 25000.00
6 27 7/12/2021 Payment 3 January 100.00
7
8 01-01-1900 6/30/2021 Receipt 1 (as per details) 4040.00
9 2 Sunday 1015.00
10 3 Monday 2025.00
11 4 Tuesday 1000.50
12 5 Round Off 0.50
13 08-01-1900 7/4/2021 Payment 1 (as per details) 1001.00
14 09-01-1900 January 100.00
15 10-01-1900 February 200.00
16 11 March 300.00
17 12 April 400.00
18 13 Round Off 1.00
19 14 7/5/2021 Receipt 3 (as per details) 4040.00
20 15 Sunday 1015.00
21 16-01-1900 Monday 2025.00
22 17 Tuesday 1000.50
23 18 Round Off 0.50
24 21 7/9/2021 Payment 2 (as per details) 1001.00
25 22 January 100.00
26 23-01-1900 February 200.00
27 24-01-1900 March 300.00
28 25-01-1900 April 400.00
29 26 Round Off 1.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 · Jul 10, 2021

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 · Jul 10, 2021

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 · Jul 11, 2021

RAJESH1960 said:
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.

RAJESH1960 · Jul 11, 2021

DanteAmor said:
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

A

B

C

D

E

F

G

1

Line

Date

Vch Type

Vch No.

Particulars

Debit

Credit

2

6

7/2/2021

Contra

1

Cash

2000.00

3

7

7/3/2021

Contra

2

Cash

25000.00

4

19

7/7/2021

Contra

3

Cash

2000.00

5

20

7/8/2021

Contra

4

Cash

25000.00

6

27

7/12/2021

Payment

3

January

100.00

7

8

1

6/30/2021

Receipt

1

(as per details)

4040.00

9

2

Sunday

1015.00

10

3

Monday

2025.00

11

4

Tuesday

1000.50

12

5

Round Off

0.50

13

8

7/4/2021

Payment

1

(as per details)

1001.00

14

9

January

100.00

15

10

February

200.00

16

11

March

300.00

17

12

April

400.00

18

13

Round Off

1.00

19

14

7/5/2021

Receipt

3

(as per details)

4040.00

20

15

Sunday

1015.00

21

16

Monday

2025.00

22

17

Tuesday

1000.50

23

18

Round Off

0.50

24

21

7/9/2021

Payment

2

(as per details)

1001.00

25

22

January

100.00

26

23

February

200.00

27

24

March

300.00

28

25

April

400.00

29

26

Round Off

1.00

Bank

DanteAmor · Jul 11, 2021

RAJESH1960 said:
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

RAJESH1960 · Jul 12, 2021

DanteAmor said:

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.

VBA code

RAJESH1960

Banned for repeated rules violations

Excel Facts

DanteAmor

Well-known Member

RAJESH1960

Banned for repeated rules violations

RAJESH1960

Banned for repeated rules violations

RAJESH1960

Banned for repeated rules violations

RAJESH1960

Banned for repeated rules violations

DanteAmor

Well-known Member

RAJESH1960

Banned for repeated rules violations

DanteAmor

Well-known Member

RAJESH1960

Banned for repeated rules violations

Similar threads

Forum statistics

Share this page

VBA code

Banned for repeated rules violations

Excel Facts

Well-known Member

Banned for repeated rules violations

Banned for repeated rules violations

Banned for repeated rules violations

Banned for repeated rules violations

Well-known Member

Banned for repeated rules violations

Well-known Member

Banned for repeated rules violations

Similar threads

Forum statistics

Share this page

We've detected that you are using an adblocker.

Which adblocker are you using?

Disable AdBlock

Disable AdBlock Plus

Disable uBlock Origin

Disable uBlock