Macros automatiques qui se bloquent

Le 27/01/2019 à 11:24

Bon, je vous explique le problème..

Au début les macros fonctionnaient mais tout d'un coup ça bug et Excel se bloque et je doit le redémarrer.

En gros il y a 3 macros qui sont censées s'activer automatiquement "worksheet_change"

1. la macro qui met à jour le choix déroulant selon la liste dans les cellules R8 à R17.

Si un choix a déjà été choisie dans la colonne C alors il sera mis à jour aussitôt que la valeur d'origine est changée (dans la liste R8 à R17).

Cette macro n'est censée être activée uniquement lorsqu'on change quelque chose dans cette liste de la colonne R.

2. la macro qui adapte la largeur des colonnes C et R:

cette macro doit être activée uniquement lorsque la valeur de leurs cellules devient plus longue ou plus petite. Dans ce cas la largeur de la colonne s'adapte en conséquence.

3. la macro qui copie et transfère les dates et les noms vers l'onglet 'daily'

Dès que j'essaye d'écrire qqch dans la colonne B ou une date dans les colonnes F /G, excel commence à réfléchir et se bloque!

Ca n'arrivait pas au début avec mes essais et tout fonctionnait parfaitement.

Je ne comprends pas...

Je vous joins le fichier entier pour que vous voyiez...

Private Sub Worksheet_Change(ByVal Target As Range)

    ActiveSheet.Unprotect "obrat"

'UPDATE CHOICES IF LIST OF ROOMS CHANGED
  Application.EnableEvents = False

    Dim zone As Range
    Set zone = Range("R8:R17")
    Set zonetest = Range("c3", Range("c" & Rows.Count).End(xlUp))

    If Not Intersect(Target, zone) Is Nothing Then
    temp = Target
    Application.Undo
        While Not zonetest.Find(Target, lookat:=xlWhole) Is Nothing
            Cells(zonetest.Find(Target, lookat:=xlWhole).Row, "c") = temp
        Wend
    Target = temp
    End If

   Application.EnableEvents = True

'AUTOMATICALLY FIT WITDH OF COLUMNS r +c

Application.ScreenUpdating = False
TCol = Array(1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11)
FTCol = UBound(TCol)
With ActiveSheet
.Columns("R").AutoFit
For Point = 0 To FTCol
If .Columns(TCol(Point)).ColumnWidth < 10.5 Then
.Columns(TCol(Point)).ColumnWidth = 10.5
End If
Next Point
End With
Application.ScreenUpdating = True

'Application.ScreenUpdating = False
TCol = Array(1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11)
FTCol = UBound(TCol)
With ActiveSheet
.Columns("C").AutoFit
For Point = 0 To FTCol
If .Columns(TCol(Point)).ColumnWidth < 10 Then
.Columns(TCol(Point)).ColumnWidth = 10
End If
Next Point
End With
Application.ScreenUpdating = True

   ActiveSheet.Protect Password:="obrat", DrawingObjects:=False, AllowFormattingCells:=True

'copy dates and names to daily

Dim WsSource As Worksheet, WsDest As Worksheet
Set WsSource = ActiveSheet
Set WsDest = Sheets("daily")

der_lig = WsSource.Range("a" & Rows.Count).End(xlUp).Row
tableau = WsSource.Range("a3", "n" & der_lig)
Dim tableauResultat
ReDim tableauResultat(1 To UBound(tableau, 1), 1 To 2)
Dim Min(1 To 1, 1 To 3)

'Tri du tableau par date de départ
For i = LBound(tableau, 1) To UBound(tableau, 1)
    tableauResultat(i, 1) = tableau(i, 6)
    tableauResultat(i, 2) = i
Next i

For i = LBound(tableauResultat, 1) To UBound(tableauResultat, 1)
    Min(1, 1) = tableauResultat(i, 1)
    Min(1, 2) = tableauResultat(i, 2)
    Min(1, 3) = i
    For h = i + 1 To UBound(tableauResultat, 1)
        If tableauResultat(h, 1) < Min(1, 1) Then
            Min(1, 1) = tableauResultat(h, 1)
            Min(1, 2) = tableauResultat(h, 2)
            Min(1, 3) = h
        End If
    Next h
    If Min(1, 3) <> i Then
        tableauResultat(Min(1, 3), 1) = tableauResultat(i, 1)
        tableauResultat(Min(1, 3), 2) = tableauResultat(i, 2)
        tableauResultat(i, 1) = Min(1, 1)
        tableauResultat(i, 2) = Min(1, 2)
    End If
Next i
'Tri terminé

'Début de l'export via des boucles
With WsDest

    .Range("a6", .Cells(Rows.Count, Columns.Count)).EntireRow.ClearContents
    .Range("a3", .Cells(Rows.Count, Columns.Count)).EntireRow.ClearContents

    nbcol = 0

    For i = LBound(tableauResultat, 1) To UBound(tableauResultat, 1)
        ligtab = tableauResultat(i, 2)
        If tableau(ligtab, 6) <> "" And tableau(ligtab, 7) <> "" Then
            For j = tableau(ligtab, 6) To tableau(ligtab, 7) - 1
                If .Range("a6").EntireRow.Find(j) Is Nothing Then
                    .Cells(6, nbcol + 1) = j
                    .Cells(7, nbcol + 1) = tableau(ligtab, 2)
                    nbcol = nbcol + 1
                Else
                    col = .Range("a6").EntireRow.Find(j).Column
                    ligne = .Cells(Rows.Count, col).End(xlUp).Row + 1
                    .Cells(ligne, col) = tableau(ligtab, 2)
                End If
            Next j
        End If
    Next i

End With

End Sub
9rooming-list.xlsm (711.80 Ko)
Le 27/01/2019 à 13:04

Bonjour toutes et tous

@Ericw

à tester une partie du début dans ton Worksheets change

Si la cellule G10 est vide, alors je cache l'image (picture1 par false) de ma feuille 1

aussi non je rends visible ma Picture1 (true)

' ..
If Worksheets("Sheet1").Range("G10").Value = "" Then ' si  le contenu de ma cellule G10 est vide !!!
Worksheets("Sheet1").Pictures("Picture1").Visible = False
Else
Worksheets("Sheet1").Pictures("Picture1").Visible = True
End If
'...

Note(s):

  • le bouton reset pour l'instant est à éviter car, il fait bugguer Excel
  • utilise des elseif tu peux regarder dans les tutoriels du forum ==> Condition cours vba<==
***

PAS BON ci-dessous:

là c'est un peu bizarre car, tu demandes à Excel si la valeur de la cellule G8 de ma feuille Sheet1 est : 1 alors ........ ma feuille1 de ma plage de cellule d'a10:l10 fontcolor en noir mais aussi, a12:l18 fontcolor en blanc ?( bon moi et les explications ce n'est pas trop mon show)

sur une plage Exemple sur a10:L10 de plusieurs cellules, L10 en noir, et a12:l18 en blanc, le programme pète un plomb là:

If ThisWorkbook.Sheets("Sheet1").Range("G8").Value = "1" Then
ThisWorkbook.Sheets("Sheet1").Range("a10:L10").Font.Color = vbBlack
ThisWorkbook.Sheets("Sheet1").Range("a12:L18").Font.Color = vbWhite

cela doit être un truc comme cela, j'pense

If ThisWorkbook.Sheets("Sheet1").Range("G8").Value = "1" Then
ThisWorkbook.Sheets("Sheet1").Range("a10:L10").Font.Color = vbBlack
else
ThisWorkbook.Sheets("Sheet1").Range("a12:L18").Font.Color = vbWhite
end if

Si la valeur de ma cellule G8 = 1 alors ma plage de cellule d'a10 à l10 doivent être de couleurs fontcolor en noir, aussinon tu mets en blanc mais de la plage a12 à l12 (si j'ai compris)

ce qui est de tes requêtes pour les dates etc. désolé peut -être ta version English d'Excel (en faites je ne sais pas)

crdlt,

André

Le 27/01/2019 à 15:46

pour l'idee de couleur des lignes, je n'ai pas de probleme.

en revanche, je n'arrive pas a effacer le contenu d'une cellule avec range.clearcontents

Le 27/01/2019 à 16:04

re,

A testé par double clic gauche de la cellule G10 de ta feuille Sheet1 (pour test)

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
With Sheets("Sheet1")
.Range("g10").Value = ClearContents
' ou
.Range("g10").Value = ""
End With
End Sub

en image

crdlt,

André

ztestg10
Le 27/01/2019 à 16:42

merci

je vais voir

Rechercher des sujets similaires à "macros automatiques qui bloquent"