VBA, kopieren naar

[gpiket7]

Ik heb een VBA script:

Private Sub CommandButton1_Click()

Dim lRij As Long
Dim c As Range
Dim iWS As Integer
Dim sBedr As String
Dim sKntr As String
Dim sInfr As String
    sBedr = "7:26"
    sKntr = "29:48"
    sInfr = "51:70"
    Application.ScreenUpdating = False
    For iWS = 2 To Worksheets.Count
        Worksheets(iWS).Range(sBedr).ClearContents
        Worksheets(iWS).Range(sKntr).ClearContents
        Worksheets(iWS).Range(sInfr).ClearContents
    Next
    For Each c In Sheets(1).[D11:D100]
        On Error Resume Next
        If Range("F" & c.Row).Value = "Bedrijfsapplicatie" Then lRij = Sheets(c.Value).[B28].End(xlUp).Row + 1
        If Range("F" & c.Row).Value = "Kantoorapplicatie" Then lRij = Sheets(c.Value).[B50].End(xlUp).Row + 1
        If Range("F" & c.Row).Value = "Infrastructuur" Then lRij = Sheets(c.Value).[B72].End(xlUp).Row + 1
        If Range("C" & c.Row).Value = "Landelijk" Then
            For iWS = 2 To Worksheets.Count
                If Range("F" & c.Row).Value = "Bedrijfsapplicatie" Then lRij = Sheets(iWS).[B28].End(xlUp).Row + 1
                If Range("F" & c.Row).Value = "Kantoorapplicatie" Then lRij = Sheets(iWS).[B50].End(xlUp).Row + 1
                If Range("F" & c.Row).Value = "Infrastructuur" Then lRij = Sheets(iWS).[B72].End(xlUp).Row + 1
                Range("A" & c.Row & ":Z" & c.Row).Copy Sheets(iWS).Range("A" & lRij)
            Next
        Else
                Range("A" & c.Row & ":Z" & c.Row).Copy Sheets(c.Value).Range("A" & lRij)
        End If
    Next
    Application.ScreenUpdating = True
End Sub

Ik heb nu 7 tabbladen;

Landelijk
Noord
Oost
West
Zuid 1
Zuid 2
Algemeen

Nu kopieert hij als C = Landelijk de gehele rij naar alle werkbladen.
Maar hij moet het alleen naar de werkbladen: Noord, Oost, West, Zuid 1, Zuid 2 kopieren.
En niet naar het werkblad Algemeen (of werkbladen die nog komen)

 

[danny147]

Beste gpiket7

Nu kopieert hij als C = Landelijk de gehele rij naar alle werkbladen.
Maar hij moet het alleen naar de werkbladen: Noord, Oost, West, Zuid 1, Zuid 2 kopieren.
En niet naar het werkblad Algemeen (of werkbladen die nog komen)

In je vorige topic schreef je het volgende bij post #28

Ziet er goed uit. Alleen als ik nu kies voor Landelijk - Alle Regio's plaatst hij deze in geen een werkblad terwijl hij deze eigenlijk naar alle werkbladen zou moet kopieren

Roncancio heeft gedaan wat je vroeg.

Groetjes Danny. :thumb:

 

[gpiket7]

Beste Danny,

Dat klopt, maar toen had mijn sheet nog niet het tabblad algemeen, dus zag ik dat probleem niet. Vandaar dat ik de vraag nu opnieuw heb gesteld, maar wel op een andere manier. Dus dat het alleen naar de werkbladen: Noord, Oost, West, Zuid 1, Zuid 2 kopieerd en niet naar de andere tabbladen, bijvoorbeeld Algemeen

Groeten Guido

 

[Warme bakkertje]

Wijzig deze regel

For iWS = 2 To Worksheets.Count

in

For iWS = 2 To 6

Zorg er dan echter ook voor dat alle nieuwe tabbladen die je aanmaakt na de regiobladen komen maw zoals in je huidige lijst na tabblad Algemeen
Dit is het risico als je werkt indexnummers voor de werkbladen. Bij een wijziging in volgorde of aantal kan je macro rare dingen gaan doen.
Het is daarom veiliger van gebruik te maken van de bladnamen ipv indexnummers. Probeer onderstaande eens uit

Private Sub CommandButton1_Click()
Dim lRij As Long, c As Range, iWS As Integer
Application.ScreenUpdating = False
    For iWS = 1 To 5
        With Sheets(Choose(iWS, "Noord", "Oost", "West", "Zuid 1", "Zuid 2"))
            Application.Union(.[7:26], .[29:48], .[51:70]).ClearContents
        End With
    Next
    For Each c In [Landelijk!D11:D100]
        On Error Resume Next
        If c.Offset(, 2).Value = "Bedrijfsapplicatie" Then lRij = Sheets(c.Value).[B28].End(xlUp).Row + 1
        If c.Offset(, 2).Value = "Kantoorapplicatie" Then lRij = Sheets(c.Value).[B50].End(xlUp).Row + 1
        If c.Offset(, 2).Value = "Infrastructuur" Then lRij = Sheets(c.Value).[B72].End(xlUp).Row + 1
        If c.Offset(, -1).Value = "Landelijk" Then
            For iWS = 1 To 5
                If c.Offset(, 2).Value = "Bedrijfsapplicatie" Then lRij = Sheets(Choose(iWS, "Noord", "Oost", "West", "Zuid 1", "Zuid 2")).[B28].End(xlUp).Row + 1
                If c.Offset(, 2).Value = "Kantoorapplicatie" Then lRij = Sheets(Choose(iWS, "Noord", "Oost", "West", "Zuid 1", "Zuid 2")).[B50].End(xlUp).Row + 1
                If c.Offset(, 2).Value = "Infrastructuur" Then lRij = Sheets(Choose(iWS, "Noord", "Oost", "West", "Zuid 1", "Zuid 2")).[B72].End(xlUp).Row + 1
                Range("A" & c.Row & ":Z" & c.Row).Copy Sheets(Choose(iWS, "Noord", "Oost", "West", "Zuid 1", "Zuid 2")).Range("A" & lRij)
            Next
        Else
                Range("A" & c.Row & ":Z" & c.Row).Copy Sheets(c.Value).Range("A" & lRij)
        End If
    Next
    Application.ScreenUpdating = True
End Sub

 

[danny147]

Beste Warme bakkertje

In je antwoord zeg je :

Wijzig deze regel
For iWS = 2 To 6

In de code schrijf je :

Application.ScreenUpdating = False
   [COLOR="Red"][B] For iWS = 1 To 5[/B][/COLOR]
        With Sheets(Choose(iWS, "Noord", "Oost", "West", "Zuid 1", "Zuid 2"))

Zie ik iets over het hoofd ?

Groetjes Danny. :thumb:

 

[Warme bakkertje]

@Danny
De eerste regel is als je gebruik wil blijven maken van de indexnummers v/d werkbladen en dus van de macro van de TS.
In mijn code maak ik gebruik van de functie Choose. De 1 to 5 is de index van de verschillende keuzemogelijkheden in de functie. Hij gaat dus bij elke loop de volgende bladnaam gebruiken overeenkomstig de index in de lijst maw loop 1=Noord, loop 2=Oost, enz.

 

[gpiket7]

Warme bakkertje,

Ik heb jouw code gebruikt en die werkt inderdaad zoals ik wil.
Dat van die indexnummers wist ik niet dus heb dat aangepast naar de bladnamen.

Groeten