VBA code

[RAJESH1960]

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						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]

I'm glad to help you. Thanks for the feedback.

 

[RPAGRAWAL_Y2K3]

thnx