Report Split - Excel VBA Doesn't Copy all Rows and runs Indefinetly

Question

I have written the following Excel VBA Macro, its job is to split a report based on CountryCode. It creates a new workbook, copies the relevant rows to a new workbook, saves the workbook by the CountryCode.

The problem I encouter is missing rows and for one worksheet, it continues running on empty rows? - Basically it doesn't stop and copies over empty rows.

Has cell formatting anything to do with it?

There is another Macro that runs only once which creates the workbooks first. It is only run once on the first worksheet, never again.

Sub RUN2_ReportSplitterOptimized()

Application.DisplayAlerts = False
Application.EnableEvents = False
' Current Workbook
    Dim cW As Workbook
    Dim cWL As String
    Dim cWN As String

    Set cW = ThisWorkbook
    cWL = cW.Path
    cWN = cW.Name

' Current Worksheet
    Dim cS As Worksheet
    Set cS = ActiveSheet

    Do Until IsEmpty(ActiveCell)

' Current Active Cell
        Dim aC As Range
        Set aC = ActiveCell

' Split input string
        Dim CC As String
        CC = splitCC(aC.Text)

        Dim wb As Workbook
        Dim ws As Worksheet

        On Error Resume Next
        Set wb = Workbooks(CC & ".xlsx")
        If Err.Number <> 0 Then
            Set wb = Workbooks.Open(cWL & "\" & CC & ".xlsx")
            ' Create the worksheet
            Set ws = wb.Sheets.Add
            ' Copy the row to the worksheet
            ws.Rows(1).Value = cS.Rows(1).Value
            ws.Rows(2).Value = aC.EntireRow.Value

            With ws
                .Name = cS.Name
            End With
        Else
            wb.Activate
            On Error Resume Next
            Set ws = wb.Sheets(cS.Name)
            If Err.Number <> 0 Then
                Set ws = wb.Sheets.Add
                ' Copy the row to the worksheet
                ws.Rows(1).Value = cS.Rows(1).Value
                ws.Rows(2).Value = aC.EntireRow.Value
                With ws
                    .Name = cS.Name
                End With
            Else
            LastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
            ws.Rows(LastRow + 1).Value = aC.EntireRow.Value
            End If
        End If
    wb.Save
    cW.Activate
    aC.Offset(1, 0).Select
    Loop
Dim wbk As Workbook
For Each wbk In Workbooks
    If Len(wbk.Name) = 7 Then
        wbk.Close
    End If
Next
End Sub

Function splitCC(countrycode As String) As String
If Len(countrycode) < 3 Then
    splitCC = countrycode
Else
    splitCC = Mid(countrycode, InStr(countrycode, "(") + 1, 2)
End If
End Function

rather than looping through each row, couldn't you just filter by country name (or code) and copy over the visible rows? Just build up a list of unique county names and loop through that. Doing it this way, you don't have to worry about blank rows (and it'll be a lot faster) — sous2817
Take out your error resume next and see it troughs an error. My guess is that it is doing that and skipping your end of loop statement. — Scott Craner
Do Until IsEmpty(ActiveCell). Dodgy. Your code looks OK, but why no replace using ActiveCell with a range variable set set be the ActiveCell prior to the loop, then adjust teh range variable using offset (like you currently do) later. This way you can be "more sure" the active cell is not changing inadvertently.. — HarveyFrench

Bart Bart · Accepted Answer · 2015-09-04T13:47:07

Solved it.

I have used filters as recommended by @sous2817 Instead of running couple of hours - it does the entire job within 2 minutes :D

Thanks for your help

Problem has been solved here: Excel VBA AutoFilter adds empty rows

Report Split - Excel VBA Doesn't Copy all Rows and runs Indefinetly

1 Answers