Error 1004: union failes

[Tjordaske]

Hi,
I'm trying to split up an Excel in several excels based on a list of values in another Excel.
Let's show an example:

You see that in the top left Excel there is a list of values. My script starts with the first value 'binnendeuren' and search that value in the first 3 columns of the middle Excel. Each row that has that value in one of its first three columns is copied to a new Exel (bottom right)

Than my script should go to (and I think here it goes wrong) to the next value (grondwerken) and do the same thing again in the middle Excel:

The first step is working well but I think that there is a problem with the loop and/or broken link in which Excel he needs to look up the value and in which Excel he needs to find the rows with that value in the first three columns, because whatever I do I get every time an error. The current error I get is a 1004 error with the 'method union is failed' message:

I hope someone can help?

 

[Tjordaske]

Here is the code:

Sub TestLoopInLoop()
Dim ocell As Range
Dim rng As Range
Dim FileName As String
Dim FilePath As String
Dim x As String
Dim i As Integer
Dim currentRange As Range
Dim currentWS As Worksheet
Dim newWB As Workbook
Dim newS As Worksheet
Dim Naam As Variant

Set currentRange = ActiveWorkbook.Worksheets(2).Range("A:C")
Set currentWS = ActiveWorkbook.Worksheets(2)

i = 1
x = Workbooks("Overzicht categorieën.xlsx").Sheets(1).Cells(i, 1).Value

Do While Not IsEmpty(Workbooks("Overzicht categorieën.xlsx").Sheets(1).Cells(i, 1))

    For Each ocell In currentRange
    If ocell.Value = x Then
        If rng Is Nothing Then
            Set rng = ocell.EntireRow
        Else
            Set rng = Union(rng, ocell.EntireRow)
        End If
    End If
    Next ocell
    Set rng = Union(rng, currentWS.Rows(1))
    rng.EntireRow.Copy
   
    FilePath = ActiveWorkbook.Path
    FileName = ActiveWorkbook.Name
    If InStr(FileName, ".") > 0 Then
        FileName = Left(FileName, InStr(FileName, ".x") - 1)
    End If
    Naam = InputBox("Onder welke naam moet het bestand opgeslagen worden?", "Meetstaat Wyckaert", FileName & " - " & x)
   
    Set newWB = Workbooks.Add
        With newWB
            Set newS = newWB.Sheets(1)
            newS.Range("A1").PasteSpecial Paste:=xlPasteColumnWidths
            newS.Range("A1").PasteSpecial Paste:=xlPasteFormats
            newS.Range("A1").PasteSpecial Paste:=xlPasteValues
            .SaveAs FileName:=FilePath & "\" & Naam
        End With

    i = 1 + 1
    Set rng = Nothing
    Loop

End Sub

 

[Alex Blakenburg]

Shouldn't this x = Workbooks("Overzicht categorieën.xlsx").Sheets(1).Cells(i, 1).Value, repeat at the end of the Do Loop ?

        i = 1 + 1
        x = Workbooks("Overzicht categorieën.xlsx").Sheets(1).Cells(i, 1).Value
        Set rng = Nothing
    Loop

and the Do loop start with:

Do While x <> ""

 

[GWteB]

@Alex Blakenburg, Imo your suggestion makes more sense.

 

[Tjordaske]

Almost there... Now the first two times goes well, but the third time it's splitting up the Excel it's a copy of the second run.

Here is the code:

Sub TestLoopInLoop()
Dim ocell As Range
Dim rng As Range
Dim FileName As String
Dim FilePath As String
Dim x As String
Dim i As Integer
Dim currentRange As Range
Dim currentWS As Worksheet
Dim newWB As Workbook
Dim newS As Worksheet
Dim Naam As Variant

Set currentRange = ActiveWorkbook.Worksheets(2).Range("A:C")
Set currentWS = ActiveWorkbook.Worksheets(2)

i = 1
x = Workbooks("Overzicht categorieën.xlsx").Sheets(1).Cells(i, 1).Value

Do While x <> ""

    For Each ocell In currentRange
    If ocell.Value = x Then
        If rng Is Nothing Then
            Set rng = ocell.EntireRow
        Else
            Set rng = Union(rng, ocell.EntireRow)
        End If
    End If
    Next ocell
    Set rng = Union(rng, currentWS.Rows(1))
    rng.EntireRow.Copy
   
    FilePath = ActiveWorkbook.Path
    FileName = ActiveWorkbook.Name
    If InStr(FileName, ".") > 0 Then
        FileName = Left(FileName, InStr(FileName, ".x") - 1)
    End If
    Naam = InputBox("Onder welke naam moet het bestand opgeslagen worden?", "Meetstaat Wyckaert", FileName & " - " & x)
   
    Set newWB = Workbooks.Add
        With newWB
            Set newS = newWB.Sheets(1)
            newS.Range("A1").PasteSpecial Paste:=xlPasteColumnWidths
            newS.Range("A1").PasteSpecial Paste:=xlPasteFormats
            newS.Range("A1").PasteSpecial Paste:=xlPasteValues
            .SaveAs FileName:=FilePath & "\" & Naam
        End With
   
    i = 1 + 1
    x = Workbooks("Overzicht categorieën.xlsx").Sheets(1).Cells(i, 1).Value
    Set rng = Nothing
    Loop

End Sub

 

[Tjordaske]

The third run/loop should only be the rows that contains the word 'pleisterwerken' in column A, B or C.

 

[RoryA]

Typo - it should be:

i = i + 1

not:

i = 1 + 1

 

[Tjordaske]

Typo - it should be:

i = i + 1

not:

i = 1 + 1

OMG!!! So stupid :D

 

[Alex Blakenburg]

What a team ! @GWteB diagnosed the problems, I converted that to code, @RoryA supervised and picked up the bits we missed