VBA For while loop help

[Weeble]

Hi! I'm need of abit of help here. Prob taken water over my head.
I'm a really green VBA coder. Been trying to google and youtube for solutions to my problem. Right now I am doing this manualy with abit of coding. But was wondering if there might be a fully automated solution to this.



My 'Blad1'(sheet1) contains a table with this information.

	A	B	C	D	E
1	City	Order	Barcode	Article	zone
2	Atlantis	123	151612	Crystal	OCE
3	Atlantis	123	151613	Boat	OCE
4	Atlantis	123	151511	Oars	LAN
5	Atlantis	123	151234	Clay statue	CRA
6	Atlantis	123	151236	Something	LAN
7	Atlantis	123	151612	Facepaint	OCE
8	Atlantis	123	151612	Plant	OCE
9	Atlantis	123	151619	Ocean	OCE
10	Pluto	321	163215	Rock 1	LAN
11	Pluto	321	132168	Rock 2	LAN
12	Pluto	321	133521	Rock 3	LA1
13	Atlantis	321	132168	Rock 4	OCE
14	Pluto	321	132168	Rock 5	LAN
15	Pluto	321	132168	Rock 6	LAN
16	Pluto	321	132168	Rock 7	LAN

<tbody>
</tbody>

Blad1​

My 'Blad2'(sheet2) has this information

	E	F	G	H
2	City :	Atlantis
3	Zone	OCE
4
5	Unique Barcodes:	151612
6		151613
7		151619

<tbody>
</tbody>

Blad2​

My goal.

I want to have a VBA For While loop that does the following.

1. From 'Blad1' Copy first unique value in column A into 'Blad2' F2(city).
2. Then I want to copy the first unique value from 'Blad1' column E(zone), that matches F2(city) in 'Blad2'F2. into 'Blad2' F3
3. I then want to add a line that prints 'Blad2'
4. Then I need to check if column E in 'Blad1' has another unique value that matches F2(city) from 'Blad2', If so, copy that next value into 'Blad2' F3
5. IF there was a new unique value, print 'Blad2' again.

For looping thrue this, it should now have found.

• City : Atlantis
• Zone: OCE
• Printed

And also copied LAN to Zone

• Printed

And also copied CRA to Zone

• Printed

Next step the FOR loop should not have found any more unique values of ZONES with the city Atlantis.
Then it should continue and look for the next unique CITY name in 'Blad1' which is Pluto.
Then continue the previous loop, but with the new unique value of Pluto.

Maybe this became more complicated then I originaly expected.

 

[JLGWhiz]

The way your scenario reads it would print a full page with a single item for the first loop,
Then, since sheet2 already has that item listed, when you add the second zone data, it would print a full page with only two items of data.
Then, a third item would be added to sheet2 and a full page printed with three items of data.
It seems to me that if you used sheet two to create a list of items similar to the one below.

City	Zone
Atlantis	OCE
Atlantis	LAN
Atlantis	CRA
Pluto	LAN
Pluto	LA1

<TBODY>
</TBODY>

then you could just print the sheet 1 time and save some paper. But maybe you need the separate sheets. If so, do you want to accumulate the data for each loop, or would you want to delete data from the previous loop and only print data from the current loop?

Also, I note that you have unique barcodes listed in your Blad2 example, but there is no mention of them in the description of what you want to copy from Blad1. Did you inadvertantly omit those from the copy requirement?

 

[Weeble]

Sorry for the late late reply JLG, I ran into a whole bunch of problem with other stuff that held me back for a while.
I'll try and explain what 'Blad2' is used for. I : M generates a list from 'Blad1' depending on that F2 and F3 has.
The Barcodes is also data from 'Blad1' Table. So this loop is to go thrue all The Cities with their respective zones, and print a sheet of paper for each zone. In 'Blad2'.

	E	F	G	H	I	J	K	L	M
2	City :	Atlantis
3	Zone	OCE
4
5	Unique Barcodes:	151612
6		151613
7		151619
8		132168		List:	Atlantis	123	151612	Crystal	OCE
9					Atlantis	123	151613	Boat	OCE
10					Atlantis	123	151612	Facepaint	OCE
11					Atlantis	123	151612	Plant	OCE
12					Atlantis	123	151619	Ocean	OCE
13					Atlantis	321	132168	Rock 4	OCE

<colgroup><col style="width: 25pxpx"><col><col><col><col><col><col><col><col><col></colgroup><thead>
</thead><tbody>
</tbody>

Blad2​

 

[JLGWhiz]

From your explaination in Post #3 , I assume that Blad 2 has formulas beginning in row 5 of Column F and in Columns I:M which will use the values in F2 and F3 to populate the applicable cells with data.

Sub t()
Dim i As Long, r As Range, fn As Range, c As Range
With Sheets("Sheet1")
    .Range("A1", .Cells(Rows.Count, 1).End(xlUp)).AdvancedFilter xlFilterCopy, , .Cells(Rows.Count, 1).End(xlUp)(3), True
    .Range("E1", .Cells(Rows.Count, 5).End(xlUp)).AdvancedFilter xlFilterCopy, , .Cells(Rows.Count, 5).End(xlUp)(3), True
    For Each c In .Cells(Rows.Count, 1).End(xlUp).CurrentRegion.Offset(1)
        If c <> "" Then
            For Each r In .Cells(Rows.Count, 5).End(xlUp).CurrentRegion.Offset(1)
                If r <> "" Then
                    Set fn = .Range("E:E").Find(r.Value, , xlValues)
                        If Not fn Is Nothing Then
                            If fn.Offset(, -4) = c.Value Then
                                With Sheets("Sheet2")
                                    .Range("F2:F3").ClearContents
                                    .Range("F2") = c.Value
                                    .Range("F3") = r.Value
                                    Sheets("Sheet2").PrintOut
                                End With
                            End If
                        End If
                End If
            Next
        End If
    Next
    .Cells(Rows.Count, 1).End(xlUp).CurrentRegion.ClearContents
    .Cells(Rows.Count, 5).End(xlUp).CurrentRegion.ClearContents
End With
End Sub

 

[JLGWhiz]

Use this instead. I inadvertantly left out a loop to ensure all combinations were checked.

Sub t2()
Dim i As Long, r As Range, fn As Range, c As Range, adr As String
With Sheets("Sheet1")
    .Range("A1", .Cells(Rows.Count, 1).End(xlUp)).AdvancedFilter xlFilterCopy, , .Cells(Rows.Count, 1).End(xlUp)(3), True
    .Range("E1", .Cells(Rows.Count, 5).End(xlUp)).AdvancedFilter xlFilterCopy, , .Cells(Rows.Count, 5).End(xlUp)(3), True
    For Each c In .Cells(Rows.Count, 1).End(xlUp).CurrentRegion.Offset(1)
        If c <> "" Then
            For Each r In .Cells(Rows.Count, 5).End(xlUp).CurrentRegion.Offset(1)
                If r <> "" Then
                    Set fn = .Range("E:E").Find(r.Value, , xlValues)
                        If Not fn Is Nothing Then
                            adr = fn.Address
                            Do
                                If fn.Offset(, -4) = c.Value Then
                                    With Sheets("Sheet2")
                                        .Range("F2:F3").ClearContents
                                        .Range("F2") = c.Value
                                        .Range("F3") = r.Value
                                        Sheets("Sheet2").PrintOut
                                    End With
                                    Exit Do
                                End If
                                Set fn = .Range("E:E").FindNext(fn)
                            Loop While adr <> fn.Address
                        End If
                End If
            Next
        End If
    Next
    .Cells(Rows.Count, 1).End(xlUp).CurrentRegion.ClearContents
    .Cells(Rows.Count, 5).End(xlUp).CurrentRegion.ClearContents
End With
End Sub