VBA code

RAJESH1960

Well-known Member
Joined
Mar 26, 2020
Messages
737
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
 

DanteAmor

Well-known Member
Joined
Dec 3, 2018
Messages
13,936
Office Version
  1. 2007
Platform
  1. Windows
I'm glad to help you. Thanks for the feedback.
 

Excel Facts

What is the shortcut key for Format Selection?
Ctrl+1 (the number one) will open the Format dialog for whatever is selected.

Forum statistics

Threads
1,148,015
Messages
5,744,349
Members
423,863
Latest member
teehexcel

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