Enige tijd geleden heb ik via dit forum een Visual Basic formule gekregen die precies deed wat ik graag wilde. Nu krijg ik bij het gebruik van de Command Button een foutmelding: "Fout 9 tijdens uitvoering. Het subscript valt buiten het bereik."
Omdat ik de formule totaal niet begrijp, weet ik ook niet hoe ik de fout moet oplossen.
De bedoeling is, dat de naam van de speler (kolom B, C, D van tabblad Teamindeling)) in het tabblad komt te staan van het team dat in kolom Q wordt genoemd. Als de speler een man is ("M" in kolom E) moet die in kolom A van het betreffende tabblad komen, als het een vrouw ("V" in kolom E) moet die in kolom B komen.
De enige verandering die ik in het bestand heb aangebracht is het toevoegen van kolom U en V, maar die zijn voor de actie van de CommandButton niet relevant.
Hieronder heb ik de formule weergegeven.
Een printscreen van de foutopsporing voeg ik bij.
Kan iemand aangeven wat ik moet aanpassen om de formule weer te laten werken??
Private Sub CommandButton1_Click()
Dim sn, arr, cl, cll As Range, j As Long, x As Long, c00 As String
Application.ScreenUpdating = False
sn = Sheets("Teamindeling").Cells(1).CurrentRegion
For Each cll In Columns(17).SpecialCells(2).Offset(1).SpecialCells(2)
If InStr(c00, cll) = 0 Then c00 = c00 & "|" & cll
Next cll
For Each cl In Split(Mid(c00, 2), "|")
ReDim arr(1, 0)
For j = 1 To UBound(sn)
If sn(j, 17) = cl Then
x = sn(j, 5) = "V"
arr(Abs(x), UBound(arr, 2)) = sn(j, 2) & IIf(Len(sn(j, 3)) > 0, " " & sn(j, 3), "") & " " & sn(j, 4)
ReDim Preserve arr(1, UBound(arr, 2) + 1)
End If
Next j
If UBound(arr, 2) > 0 Then
If IsError(Evaluate("'" & cl & "'!A1")) Then Sheets.Add(, Sheets(Sheets.Count)).Name = cl
With Sheets(cl)
.Cells(1).CurrentRegion.ClearContents
.Cells(1).Resize(UBound(arr, 2), 2) = Application.Transpose(arr)
If arr(0, 0) <> "" Or arr(0, 1) <> "" Then
On Error Resume Next
If arr(0, 0) <> "" Or arr(0, 1) <> "" Then
.Columns(1).Resize(, 2).SpecialCells(4).Delete
Else
.Columns(2).SpecialCells(4).Delete
End If
On Error GoTo 0
End If
End With
End If
Erase arr
Next cl
End Sub
Omdat ik de formule totaal niet begrijp, weet ik ook niet hoe ik de fout moet oplossen.
De bedoeling is, dat de naam van de speler (kolom B, C, D van tabblad Teamindeling)) in het tabblad komt te staan van het team dat in kolom Q wordt genoemd. Als de speler een man is ("M" in kolom E) moet die in kolom A van het betreffende tabblad komen, als het een vrouw ("V" in kolom E) moet die in kolom B komen.
De enige verandering die ik in het bestand heb aangebracht is het toevoegen van kolom U en V, maar die zijn voor de actie van de CommandButton niet relevant.
Hieronder heb ik de formule weergegeven.
Een printscreen van de foutopsporing voeg ik bij.
Kan iemand aangeven wat ik moet aanpassen om de formule weer te laten werken??
Private Sub CommandButton1_Click()
Dim sn, arr, cl, cll As Range, j As Long, x As Long, c00 As String
Application.ScreenUpdating = False
sn = Sheets("Teamindeling").Cells(1).CurrentRegion
For Each cll In Columns(17).SpecialCells(2).Offset(1).SpecialCells(2)
If InStr(c00, cll) = 0 Then c00 = c00 & "|" & cll
Next cll
For Each cl In Split(Mid(c00, 2), "|")
ReDim arr(1, 0)
For j = 1 To UBound(sn)
If sn(j, 17) = cl Then
x = sn(j, 5) = "V"
arr(Abs(x), UBound(arr, 2)) = sn(j, 2) & IIf(Len(sn(j, 3)) > 0, " " & sn(j, 3), "") & " " & sn(j, 4)
ReDim Preserve arr(1, UBound(arr, 2) + 1)
End If
Next j
If UBound(arr, 2) > 0 Then
If IsError(Evaluate("'" & cl & "'!A1")) Then Sheets.Add(, Sheets(Sheets.Count)).Name = cl
With Sheets(cl)
.Cells(1).CurrentRegion.ClearContents
.Cells(1).Resize(UBound(arr, 2), 2) = Application.Transpose(arr)
If arr(0, 0) <> "" Or arr(0, 1) <> "" Then
On Error Resume Next
If arr(0, 0) <> "" Or arr(0, 1) <> "" Then
.Columns(1).Resize(, 2).SpecialCells(4).Delete
Else
.Columns(2).SpecialCells(4).Delete
End If
On Error GoTo 0
End If
End With
End If
Erase arr
Next cl
End Sub
