VBA, waarde over tabbladen verdelen

[gpiket7]

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, "Zuid West", "Zuid Oost", "West", "Noord Oost", "LVO"))
            Application.Union(.[7:25], .[29:47], .[51:69]).ClearContents
        End With
    Next
    For Each c In [UMG!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 = "Systeemapplicatie" 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, "Zuid West", "Zuid Oost", "West", "Noord Oost", "LVO")).[B28].End(xlUp).Row + 1
                If c.Offset(, 2).Value = "Kantoorapplicatie" Then lRij = Sheets(Choose(iWS, "Zuid West", "Zuid Oost", "West", "Noord Oost", "LVO")).[B50].End(xlUp).Row + 1
                If c.Offset(, 2).Value = "Systeemapplicatie" Then lRij = Sheets(Choose(iWS, "Zuid West", "Zuid Oost", "West", "Noord Oost", "LVO")).[B72].End(xlUp).Row + 1
                Range("A" & c.Row & ":Z" & c.Row).Copy Sheets(Choose(iWS, "Zuid West", "Zuid Oost", "West", "Noord Oost", "LVO")).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

Bij de optie landelijk schrijft hij alles weg naar meerdere tabbladen, nu wil ik dat dit ook gebeurd als de optie SBC is gekozen, maar ik krijg het niet verwerkt. Iemand een idee?

 

[snb]

Mij lijkt dit voldoende

Private Sub CommandButton1_Click()
  Application.Screenupdating=False
  sq=split("Zuid West|Zuid Oost|West|Noord Oost|LVO","|")
  Sheets(sq(0)).range("7:25,29:47,15:69").ClearContents
  sheets(sq).FillAcrossSheets Sheets(sq(0)).range("7:25,29:47,15:69")

  For Each cl In [UMG!D11:D100]
    If cl.Offset(, -1).Value = "Landelijk" or cl.offset(,-1)="SBC" Then
       x=sheets(sq(0)).cells(28+22* instr("KS",left(cl.offset(,2),1)),2).End(xlUp).Offset(1).Row
       sheets(sq(0)).rows(x)=cl.entirerow.value
       sheets(sq).FillAcrossSheets Sheets(sq(0)).rows(x)
    Else
      sheets(cl.Value).rows(Sheets(cl.Value).cells(28+22* instr("KS",left(cl.offset(,2),1)),2).End(xlUp).Offset(1).Row )=cl.entirerow.value
    End If
  Next
  Application.ScreenUpdating = True
End Sub

 

[gpiket7]

Met jou stuk code krijg ik een error 1004
Kan niet worden uitgevoer op meerdere selecties

 

[snb]

Dan wordt het:

Private Sub CommandButton1_Click()
  Application.Screenupdating=False
  sq=split("Zuid West|Zuid Oost|West|Noord Oost|LVO","|")
  Sheets(sq(0)).range("7:25,29:47,51:69").ClearContents
[COLOR="Blue"]  sheets(sq).FillAcrossSheets Sheets(sq(0)).range("7:69")[/COLOR]

  For Each cl In [UMG!D11:D100]
    If cl.Offset(, -1).Value = "Landelijk" or cl.offset(,-1)="SBC" Then
       x=sheets(sq(0)).cells(28+22* instr("KS",left(cl.offset(,2),1)),2).End(xlUp).Offset(1).Row
       sheets(sq(0)).rows(x)=cl.entirerow.value
       sheets(sq).FillAcrossSheets Sheets(sq(0)).rows(x)
    Else
      sheets(cl.Value).rows(Sheets(cl.Value).cells(28+22* instr("KS",left(cl.offset(,2),1)),2).End(xlUp).Offset(1).Row )=cl.entirerow.value
    End If
  Next
  Application.ScreenUpdating = True
End Sub

 

[gpiket7]

Bedankt, het werkt! :thumb: