VBA to copy rows to new sheet when criteria met

[pompey007]

I have limited VBA knowledge but willing to learn!

I have a nominal ledger download that lists the following in columns A + B (along with lots of other data in columns C to P which will need to be copied but will not be a driver), what I would like to do is to use VBA to run through the data and copy the rows each time that column A has the text "Ledger account" for all rows until "ledger account" appears again and paste to a new sheet for each ledger code.

Date Voucher
Ledger account 71110
31/12/2010 1DGL000411
31/12/2010 1DGL000411
31/12/2010 1DGL000411
31/12/2010 1DGL000411
31/12/2010 1DGL000415
31/01/2011 1DGL000707
31/01/2011 1DGL000707
31/01/2011 1DGL000707
31/01/2011 1DGL000707
31/01/2011 1DGL000746
28/02/2011 1DGL000957
28/02/2011 1DGL000957
28/02/2011 1DGL000957
28/02/2011 1DGL000957
Ledger account 71110


Ledger account 71170
12/11/2010 1DGL000160
30/11/2010 1DAJ000002
04/01/2011 1DGL000579
31/01/2011 1DGL000657
Ledger account 71170


Ledger account 71210
31/12/2010 1DGL000411
31/12/2010 1DGL000411
31/01/2011 1DGL000707
31/01/2011 1DGL000707
31/01/2011 1DGL000746
28/02/2011 1DGL000957
28/02/2011 1DGL000957
Ledger account 71210

 

[jbeaucaire]

As long as there is at least one blank row between each group as you've shown, then this should work.

Option Explicit

Sub ParseToSheets()
Dim LdgRNG As Range
Dim LdgArea As Long
Dim MyStr   As String
Application.ScreenUpdating = False

Set LdgRNG = ActiveSheet.Range("A:A").SpecialCells(xlConstants)

For LdgArea = 1 To LdgRNG.Areas.Count
    LdgRNG.Areas(LdgArea).EntireRow.Copy
    Sheets.Add After:=Sheets(Sheets.Count)
    Range("A1").PasteSpecial xlPasteAll
    MyStr = Range("A" & Rows.Count).End(xlUp)
    MyStr = Mid(MyStr, InStrRev(MyStr, " ") + 1, Len(MyStr))
    ActiveSheet.Name = MyStr
Next LdgArea

Application.ScreenUpdating = True
End Sub

 

[pompey007]

Thanks for your help.

Can you clarify how/where to place this into workbook? Get a bit confused between all the various windows/projects/properties etc

I have use ALT + F11 and then pasted code. Then I have run the routine ParseToSheets(), the following happens

It creates a new worksheet - account
It creates another new worksheet Sheetx
It then gives a 400 error,

 

[jbeaucaire]

1) Is there at least one blank row between each "group" of data?

2) Is there data actually in column A? If not, the macro will failr from the start. See how the LdgRNG is set using that column?

3) Alt-F11 to enter VBEditor, then Insert > Module to create an empty module, paste the code into that module.

4) When you run the macro you have ensure the Activesheet onscreen is the one with the data, the use Alt-F8 to activate the macro.

 

[pompey007]

I have been working through the code line-by-line to try and understand how it works, I can understand most of the basics (defining subs, declaring Dims etc) but the main body of it is a bit beyond me at the moment!

In answer to your questions

1) Is there at least one blank row between each "group" of data? Yes

2) Is there data actually in column A? If not, the macro will failr from the start. See how the LdgRNG is set using that column? Yes


3) Alt-F11 to enter VBEditor, then Insert > Module to create an empty module, paste the code into that module.

4) When you run the macro you have ensure the Activesheet onscreen is the one with the data, the use Alt-F8 to activate the macro.

Have done stages 3 + 4 and ensured that the data sheet is the active sheet.

Seem to have an issue with the rename of sheets - get runtime error 1004. Is it possible to name the sheets as per the ledger code in column B (eg 71110, 71170) rather than sheetx?

 

[jbeaucaire]

Is it possible to name the sheets as per the ledger code in column B (eg 71110, 71170) rather than sheetx?

That's exactly what the code is trying to do.

Here's the sample sheet I used, posted to my code site...

LedgersToSheets.xls​

There's a link on the FILES page where you can send me your file, but this should work. Compare your data, is there something notably different about the ledger account lines?

 

[pompey007]

Hi,

Reviewed the sample sheet and almost there - thanks again!

When I remove the line:

ActiveSheet.Name = MyStr

the macro runs fine, it sets up all the sheets but obviously they are not very intuitive as they are called sheet 11,12,13 etc.

I assume that the string "MyStr" is trying to name the sheet based on the formula in the code using Mid & Len. It appears to be falling over at this stage as I get the error message "cannot rename a sheet to the same name as another sheet, a referenced object library or workbook referenced by visual basic", I cannot see where the conflict would arise, but is there a workaround?

 

[jbeaucaire]

If you're running that code on the same workbook I gave, did it give you the same error? It doesn't for me. Maybe this is another oddity with Excel and naming worksheets for numbers.

Try this, I can't test since it's working for me already:

ActiveSheet.Name = MyStr & ""

If it does fail, DEBUG and give me the current value of MyStr, does that sheet truly not exist in your workbook currently?

You can also send me your file, I guess.

 

[jbeaucaire]

Ok, now that I've seen your worksheet, the account numbers were in column B, not column A, that was what was causing the error naming the sheet. Here's the final code with comments:

Option Explicit

Sub ParseToSheets()
Dim wsTemp  As Worksheet     'temp sheet created where we delete unneeded rows
Dim pgFIND  As Range         'used to delete the headers/footers around Page #
Dim LdgRNG  As Range
Dim LdgArea As Long
Application.ScreenUpdating = False
Application.DisplayAlerts = False

Sheets("Data Dump").Copy Before:=Sheets(1)  'create copy of raw data we can edit
Set wsTemp = ActiveSheet

wsTemp.Rows("1:2").Delete xlShiftUp     'delete header rows
On Error Resume Next        'look for Page # rows and delete rows around them
Set pgFIND = wsTemp.Cells.Find("Page ", LookIn:=xlValues, LookAt:=xlPart)

If Not pgFIND Is Nothing Then
    Do      'sometimes need to delete 7 rows, sometimes 8 rows
        If wsTemp.Range("A" & pgFIND.Row + 7).Value = "" Then
            pgFIND.Resize(8).EntireRow.Delete xlShiftUp
        Else
            pgFIND.Resize(7).EntireRow.Delete xlShiftUp
        End If
        Set pgFIND = wsTemp.Cells.Find("Page ", LookIn:=xlValues, LookAt:=xlPart)
    Loop Until pgFIND Is Nothing    'quit when no more Page # rows found
End If

Set LdgRNG = wsTemp.Range("A:A").SpecialCells(xlConstants)  'memorize the "groups" in column A

For LdgArea = 1 To LdgRNG.Areas.Count           'for each group of data in column A
    LdgRNG.Areas(LdgArea).EntireRow.Copy        'copy the group of rows
    Sheets.Add After:=Sheets(Sheets.Count)      'create a new sheet
    Range("A1").PasteSpecial xlPasteAll         'paste in the group of copied rows
    Range("A1").Select                          'select A1
    ActiveSheet.Name = _
        Range("B" & Rows.Count).End(xlUp).Value 'Name the sheet for account number
    ActiveSheet.Columns.AutoFit                 'clean up column widths
Next LdgArea                                    'repeat with next group

wsTemp.Delete                                   'delete the copy of raw data
Application.ScreenUpdating = True
Sheets("Data Dump").Activate                    'return to raw data starting point
End Sub

 

[pompey007]

Many thanks! Apologies for not seeing that the account codes were in Col B!

The code does exactly what is required, will now spend a bit of time trying to understand the code with your very useful comments. Also need to work on my knowledge of "modules" and which workbooks they are available with.

Once again, thanks.