Macro to copy / delete rows when a certain criteria is met

[chickendippaz]

Hi all,

I have been trying to write a macro to clean up a download of the general ledger from an accounting system.

What I would like the macro to do is four things (in this order);

1) Locate the value 'G/L #' in column A, then delete the row it is on along with the 12 rows above it and 2 rows below it. There are multiple exsistences of the value 'G/L #' in column A.

2) Insert a column in between D & E

3) Where column B contains a date value, concatenate the data in column C & D on the row below it, then cut and paste this into the newly created column E.

4) Finally, delete any remaining blank rows.

If you would like to see this ledger in excel please contact me and I will email you a copy.

Many thanks for your help,

Sam

 

[JLGWhiz]

Try this on a copy of your file first. Deletions by code cannot be reversed using the undo button.

Code:
Sub ject()
Dim sh As Worksheet, lr As Long, rng As Range
Set sh = Sheets(1) 'Edit sheet name
lr = sh.Cells(Rows.Count, 1).End(xlUp).Row
Set rng = Range("A2:A" & lr)
For Each c In rng
If c.Value = "G/L #" Then
c.Offset(-12, 0).Resize(15, 1).EntireRow.Delete
End If
Next
Columns("E").Insert
For Each r In sh.Range("B2", sh.Cells(Rows.Count, 2).End(xlUp))
If IsDate(r.Value) = True Then
r.Offset(0, 3) = r.Offset(0, 1).Value & r.Offset(0, 2).Value
sh.Range("C" & r.Row, "D" & r.Row).ClearContents
End If
Next
For Each rw In sh.UsedRange.Rows
If WorksheetFunction.CountA(rw.EntireRow) = 0 Then rw.EntireRow.Delete
Next
End Sub
Code:

 

[chickendippaz]

Try this on a copy of your file first. Deletions by code cannot be reversed using the undo button.

Code:
Sub ject()
Dim sh As Worksheet, lr As Long, rng As Range
Set sh = Sheets(1) 'Edit sheet name
lr = sh.Cells(Rows.Count, 1).End(xlUp).Row
Set rng = Range("A2:A" & lr)
For Each c In rng
If c.Value = "G/L #" Then
c.Offset(-12, 0).Resize(15, 1).EntireRow.Delete
End If
Next
Columns("E").Insert
For Each r In sh.Range("B2", sh.Cells(Rows.Count, 2).End(xlUp))
If IsDate(r.Value) = True Then
r.Offset(0, 3) = r.Offset(0, 1).Value & r.Offset(0, 2).Value
sh.Range("C" & r.Row, "D" & r.Row).ClearContents
End If
Next
For Each rw In sh.UsedRange.Rows
If WorksheetFunction.CountA(rw.EntireRow) = 0 Then rw.EntireRow.Delete
Next
End Sub
Code:

Hi JLG,

Thanks for the code, have tested it and it seems to be 90% there however it seems to be concatenating the wrong cells and moving one of the cells of data on the line below. I tried to tinker with it but my VB skills are begginer at best so didnt have any luck with it.


If you PM me your email I can send you the source data if that helps?

Really appricate the help with this as it will save me hours of manually tidying up the data.

 

[JLGWhiz]

Hi JLG,

Thanks for the code, have tested it and it seems to be 90% there however it seems to be concatenating the wrong cells and moving one of the cells of data on the line below. I tried to tinker with it but my VB skills are begginer at best so didnt have any luck with it.


If you PM me your email I can send you the source data if that helps?

Really appricate the help with this as it will save me hours of manually tidying up the data.

I don't accept personal email attachements from the forum, but I think I have fixed the problem. Give this revision a try. I did not understand this statement, " and moving one of the cells of data on the line below" since the previous code did nothing to the line below, unless it was a blank line, which would ultimately be deleted. Anyhow, give this a try and let me post back with the results.

Code:
Sub ject2()
Dim sh As Worksheet, lr As Long, rng As Range
Set sh = Sheets(1) 'Edit sheet name
lr = sh.Cells(Rows.Count, 1).End(xlUp).Row
Set rng = Range("A2:A" & lr)
For Each c In rng
If c.Value = "G/L #" Then
c.Offset(-12, 0).Resize(15, 1).EntireRow.Delete
End If
Next
Columns("E").Insert
For Each r In sh.Range("B2", sh.Cells(Rows.Count, 2).End(xlUp))
If IsDate(r.Value) = True Then
r.Offset(1, 3) = r.Offset(1, 1).Value & r.Offset(1, 2).Value
sh.Range("C" & r.Row, "D" & r.Row).ClearContents
End If
Next
For Each rw In sh.UsedRange.Rows
If WorksheetFunction.CountA(rw.EntireRow) = 0 Then rw.EntireRow.Delete
Next
End Sub
Code:

 

[JLGWhiz]

Oops! Forgot to change the row to clear the concatenated data. Use this version.

Code:
Sub ject3()
Dim sh As Worksheet, lr As Long, rng As Range
Set sh = Sheets(1) 'Edit sheet name
lr = sh.Cells(Rows.Count, 1).End(xlUp).Row
Set rng = Range("A2:A" & lr)
For Each c In rng
If c.Value = "G/L #" Then
c.Offset(-12, 0).Resize(15, 1).EntireRow.Delete
End If
Next
Columns("E").Insert
For Each r In sh.Range("B2", sh.Cells(Rows.Count, 2).End(xlUp))
If IsDate(r.Value) = True Then
r.Offset(1, 3) = r.Offset(1, 1).Value & r.Offset(1, 2).Value
sh.Range("C" & r.Row + 1, "D" & r.Row + 1).ClearContents
End If
Next
For Each rw In sh.UsedRange.Rows
If WorksheetFunction.CountA(rw.EntireRow) = 0 Then rw.EntireRow.Delete
Next
End Sub
Code: