scripts samenvoegen

[moensk]

Ik gebruik onderstaand script om rijen te copieren naar ander tabblad afhankelijk wat er in kolom "AQ" staat.
vraag
in kolom AQ kunnen 20 verschillende namen voorkomen
ik heb 20 tabbladen en zou dus 20 keer dit script kunnen laten lopen.
Kan dit in één script ?
de naam in kolom AQ is ook de naam van het Tabblad waartoe het gekopieerd moet worden

Sub kopie()
Dim x As Integer
With Sheets("Data")
For x = 2 To .Range("A" & .Rows.Count).End(xlUp).Row
If Application.Or(.Range("AQ" & x).Value = "Delhaize") Then
.Range("A" & x & ":U" & x).Copy Sheets("Delhaize").Range("A" & Sheets("Delhaize").Range("A" & Sheets("Delhaize").Rows.Count).End(xlUp).Row + 1)
End If
Next x
End With
Sheets("Delhaize").Cells(1).CurrentRegion.RemoveDuplicates 3
End Sub

 

[AHulpje]

Zoiets:

Sub kopie()
    Dim x As Integer
    Dim DoelSheet As String
    With Sheets("Data")
        For x = 2 To .Range("A" & .Rows.Count).End(xlUp).Row
            DoelSheet = .Range("AQ" & x).Value
            .Range("A" & x & ":U" & x).Copy Sheets(DoelSheet).Range("A" & Sheets(DoelSheet).Range("A" & Sheets(DoelSheet).Rows.Count).End(xlUp).Row + 1)
        Next x
    End With
    Sheets(DoelSheet).Cells(1).CurrentRegion.RemoveDuplicates 3
End Sub

 

[moensk]

Ik krijg een foutmelding dat script buiten bereik valt
in bijlage een klein voorbeeld bestandje

 

[AHulpje]

Kolom AQ is slechts gedeeltelijk gevuld, dan is DoelSheet="".
"Lege" doelsheets overslaan?

 

[moensk]

rijen waarbij doelsheet leeg is dienen niet gekopieerd te worden

 

[AHulpje]

Kleine wijziging:

            If DoelSheet <> "" Then
                .Range("A" & x & ":U" & x).Copy Sheets(DoelSheet).Range("A" & Sheets(DoelSheet).Range("A" & Sheets(DoelSheet).Rows.Count).End(xlUp).Row + 1)
            End If

 

[moensk]

Ahulpje
hij doet het doch nu verwijdert hij de dubbele waardes niet meer

 

[AHulpje]

Oeps, RemoveDuplicates even verplaatsen:

Sub kopie()    Dim x As Integer
    Dim DoelSheet As String
    With Sheets("Data")
        For x = 2 To .Range("A" & .Rows.Count).End(xlUp).Row
            DoelSheet = .Range("AQ" & x).Value
            If DoelSheet <> "" Then
                .Range("A" & x & ":U" & x).Copy Sheets(DoelSheet).Range("A" & Sheets(DoelSheet).Range("A" & Sheets(DoelSheet).Rows.Count).End(xlUp).Row + 1)
                Sheets(DoelSheet).Cells(1).CurrentRegion.RemoveDuplicates 3
            End If
        Next x
    End With
End Sub

 

[moensk]

Ahulpje
werkt super.
volgende probleem had ik niet verwacht
kolom "H" zijn de datums. Ik filter daar 1 datum uit.
Nu blijkt dat bij de export naar de tabbladen er geen rekening wordt gehouden met die filter maar dat hij dus alle datums neemt.
hebt ge daar nog een oplossing voor ?

 

[AHulpje]

Had ik ook niet verwacht, maar daar is een oplossing voor, testen of de betreffende rij zichtbaar is:

Sub kopie()
    Dim x As Integer
    Dim DoelSheet As String
    With Sheets("Data")
        For x = 2 To .Range("A" & .Rows.Count).End(xlUp).Row
            If Not .Rows(x).Hidden Then
                DoelSheet = .Range("AQ" & x).Value
                If DoelSheet <> "" Then
                    .Range("A" & x & ":U" & x).Copy Sheets(DoelSheet).Range("A" & Sheets(DoelSheet).Range("A" & Sheets(DoelSheet).Rows.Count).End(xlUp).Row + 1)
                    Sheets(DoelSheet).Cells(1).CurrentRegion.RemoveDuplicates 3
                End If
            End If
        Next x
    End With
End Sub

 

[moensk]

Ahulpje
werkt super !!!
thanks voor de snelle hulp