probleme boucle VB code

ridhaghanmi

XLDnaute Nouveau
salut a tous,
j ai besoin de votre aide mes amis.
j ai un probleme avec mon code quand j ajoute une colonne entre C et D , la macro s arrete et donne pas le resultat volu. Voici le code et le fichier.

Code:
Private Sub cmdok_Click()

Dim x, y, z, temp, result, r_split, seat, myvalues, mycolours
Dim i As Long, k As Long, n As Long, offs As Long
Dim Gamedata As String

With Sheets(frmgame.cmbarea.Text)
    
    Application.ScreenUpdating = 0
    
    .Range("E2:EX300").Clear

    With Sheets("Gamedata")

        x = .Range("a2", .Cells(Rows.Count, "a").End(xlUp)).Resize(, 16)
    
        ReDim y(1 To UBound(x))
    
    End With
    
    For i = 1 To UBound(x)

        y(i) = x(i, 1) & x(i, 2) & x(i, 3) & "|" & x(i, 4) & "|" & x(i, 5) & "|" & x(i, 15)

    Next
    
    If .Range("c2") <> "" Then
    
        z = .Range("c2", .Cells(Rows.Count, "c").End(xlUp)).Resize(, 2)
    
        ReDim result(1 To UBound(z), 1 To 150)
    
        For i = 1 To UBound(z)
        
            If z(i, 2) <> "" Then
            
                Gamedata = Me.cmbgame.Text & Me.cmbstand.Text & Me.cmbarea.Text & "|" & z(i, 2) & "|"
            
                temp = Filter(y, Gamedata, 1)
            
                If UBound(temp) > -1 Then
                
                    For n = 0 To UBound(temp)
                
                        r_split = Split(temp(n), "|")
                    
                        offs = CLng(r_split(2))
                        seat = r_split(3)
                    
                        k = k + offs + 1
                        
                        result(i, k) = seat
                    
                    Next
                
                End If
                
            End If
            
            k = 0
            
        Next
    
        .Range("e2").Resize(UBound(result), UBound(result, 2)) = result
    
    End If


    
    .Range("a1") = frmgame.cmbgame.Text
    .Columns("E:EX").ColumnWidth = 4.29
    .Columns("B:D").ColumnWidth = 8
  
    'This is the code for colour coding the calendar using the different letters'
   
    With .Range("E2:EX300")
    
        .Replace "P", "RES", xlWhole
        .Replace ".", "S", xlWhole
        .Replace "04", "C", xlWhole
        
        'colouring
        myvalues = Split("A,RES,BS,DS,HP,OB,RV,SV,UV,X,RA,C,S,RR", ",")
        mycolours = Array(4, 10, 10, 10, 10, 10, 10, 10, 10, 15, 45, 41, 3, 27)
        
        With Application.ReplaceFormat
            .HorizontalAlignment = xlCenter
            .VerticalAlignment = xlCenter
            .Font.Bold = True
            With .Borders
                .LineStyle = xlContinuous
                .Weight = xlThin
            End With
        End With
        
        For i = 0 To UBound(mycolours)
            Application.ReplaceFormat.Interior.ColorIndex = mycolours(i)
            .Replace what:=myvalues(i), replacement:=myvalues(i), lookat:=xlWhole, searchformat:=False, ReplaceFormat:=True
        Next

    End With
        
    .Activate

End With

Application.ScreenUpdating = 1

End Sub

merci pour votre aide
 

Pièces jointes

  • Stadium_edited_all_revised.xlsm
    296.9 KB · Affichages: 44

Statistiques des forums

Discussions
312 559
Messages
2 089 641
Membres
104 239
dernier inscrit
STEVEALL