D'extension Code pour Super Dévelopeur Excel 2007
Curulis57 Bonjour et Merci
Désolé de mettre un certain temps pour te répondre mais j'étais en Mode Test pour ne pas t'induire en Erreur.
le Verdict c'est que tu es un très Bon que dis-je un Excellent codeur.
La restitution est parfaite avec un petit hic perso pour le second scenario que tu viens de créer
en effet serait-il possible de recopier la ligne suivante plutôt que la ligne contenant le "0"
car en colonne G tous ce qui ce termine par R,S,T,U,V sont des Portes et la machine sont les Lettres d'avant.
Exemple WDC01R MachinePorte
Je te transmet les félicitations du groupe et Merci pour nous avoir fait toucher du doigt cette faille longtemps ignoré, il aura fallu qu'une personne avec un regard nouveau en occurrence toi nous mettent sur la voie.
Bien cordialement
Daniel
Salut Barachoie,
OK, mais souci en lignes 7-8 où les conditions sont rencontrées pour le 2e scénario.
Je veux bien supprimer la ligne '0' (la 7, donc) mais, en ligne 8, j'ai : BUG SI CETTE LIGNE EST PRESENT.
Est-ce à dire que je peux (pas assez de lignes pour me faire une idée précise...) aveuglément :
- prendre l'intitulé de la colonne [E] (DEPTR) ;
- dans le même esprit, quid de l'intitulé en [G] ?
Question subsidiaire, juste pour être sûr et certain : dans le 2e scénario, les valeurs des lignes "0" et "25" en [D] doivent bien être identiques, n'est-ce pas ?
A+
Salut Curulis57,
Oui colonne D identique
Pour le Deuxieme Scenario laisse comme avant je me contente des Portes tel quel
Curulis57 en rajoutant des lignes plus fourni sa Bug !!!! c'est gênant car on se rapproche d'un fichier Usuel de traitement
as-tu une idée pour le contourner ?
Merci
Bien cordialement
Salut Barachoie,
j'ai compris le problème mais au-delà de ça, comme coupeur de cheveux en quatre, j'ai quand même des questions.
Le dernier fichier que tu m'a transmis est un fichier déjà à moitié traité ?
Quoiqu'il en soit, en y regardant de plus près, l'application aveugle du 2e scénario ne risque-t-elle pas de fausser des résultats existants ?
Par exemple :
- [C31] = 0, [C32] = 4, donc scénario 2 mais intitulés en [E] différents ;
- [C131] = 0, [C132] = 1 (comme en beaucoup d'endroits et soit-dit en passant l'origine du bug), donc scénario 2 puisque [K] = 1 mais apparemment déjà complété de [C132] à [C156] de 1 à 25 ;
- [C1261] = 0, [C1262] = 22, donc scénario 2 ([K] = 1) mais déjà développé sur 10 lignes -> [C1271] : le 2e scénario ajoute 22 lignes!
Bref, j'exagère peut-être (et je n'ai pas scanné toutes les 23.000 lignes!) et me tracasse pour rien mais j'aimerais que tu me précises un protocole bien ficelé en fonction des situations multiples et complexes que le code va rencontrer, histoire d'éviter les déceptions.
A te lire,
A+
Bonjour et Merci Curulis57,
Le nouveau scénario demande en effet réflexion et tu as raison de le souligner. Je vais essayer de définir une règle pour déterminer Quand le déclencher du fait que c'est un cas nouveau c'est vrai que l'on a pas eu le temps de se poser car je l'ai découvert en même temps que toi.
Par Avance Merci et surtout je note une implication sans faille et admirable de ta part et je t'en félicite car tu as l'oeil avisé et pertinent
Bien cordialement et bon week-End
Daniel
Bonsoir à tous,
La même question me taraude depuis le début : comment sont déterminés ces fameux blocs
Ici je restitue les dits blocs en me basant sur la colonne 7 ---> Entity
Restitution dans une feuille annexe :
Option Explicit
Sub les_blocs()
Dim i As Long, j As Long, n As Long, SL As Object, pStack As Object
Set SL = CreateObject("System.Collections.SortedList")
Set pStack = CreateObject("System.Collections.Stack")
Application.ScreenUpdating = False
With Sheets("lg RaptorXX")
'on parcourt la feuille "lg RaptorXX"
'de la derniere ligne à la deuxieme
For i = .Cells(.Rows.Count, "g").End(xlUp).Row To 2 Step -1
If .Cells(i, 3).Value <> 0 Then
j = 1
Do Until .Cells(i, 7) <> .Cells(i, 7)(j)
If Not pStack.Contains(.Cells(i, 3)(j).Value) Then
pStack.Push .Cells(i, 3)(j).Value
End If
j = j - 1
Loop
SL(i + j) = pStack.ToArray()
pStack.Clear
i = i + j
End If
Next i
End With
On Error Resume Next
Application.DisplayAlerts = False
Sheets("Blocs").Delete
Sheets.Add().Name = "Blocs"
On Error GoTo 0
With Sheets("Blocs")
.Columns(1).ColumnWidth = 23
n = 1
For i = 0 To SL.Count - 1
.Cells(n, 1).Value = "Début du bloc : ligne " & SL.GetKey(i) & Chr(10) & _
"bloc de " & UBound(SL.GetByIndex(i)) + 1 & " éléments en colonne C"
.Cells(n, 2).Resize(UBound(SL.GetByIndex(i)) + 1).Value = Application.Transpose(SL.GetByIndex(i))
With .Cells(n, 1).CurrentRegion
.BorderAround Weight:=xlThin
.Borders(xlInsideVertical).Weight = xlThin
.VerticalAlignment = xlCenter
With .Cells(1)
.Interior.ColorIndex = 44
.BorderAround Weight:=xlThin
End With
End With
n = n + UBound(SL.GetByIndex(i)) + 2
Next
End With
Set SL = Nothing: Set pStack = Nothing
Application.ScreenUpdating = True
End SubBonne fêtes à tous
klin89
Salut Klin,
Bienvenue dans l'aventure!
- 1er scénario : si [Cxx] = 0 et [Dxx] <> [Dxx + 1] alors on insère [Lxx] lignes et on reproduit [Lxx] X la ligne xx ;
* si [Lxx]= 25, on initialise simplement de [Cxx] à [Cxx + [Lxx]] de 1 à 25 ;
* si [Lxx] < 25, on cherche dans le tableau, SOUS xx, une ligne où [Lyy]= [Lxx] et on initialise de [Cxx] à [Cxx + [Lxx]] avec les valeurs reprises en [Cyy...] ;
* les blocs ainsi reconstitués sont mis en BLANC GRAS.
* les blocs < 25 non-trouvés SOUS xx sont à retenir pour permettre à Barachoie de vérifier les valeurs en [C].
- 2e scénario : si [Cxx] > 0 et [Cxx - 1] = 0 et [Dxx] = [Dxx -1] et [Kxx] = 1, on insère [Cxx] lignes (pas [Lxx]...) qu'on initialise de la même façon que le 1er scénario.
... sauf erreur..., les neurones chauffant très fort...
A+
Re,
Désolé mais je fais une fixation sur les dits blocs
Dans une feuille annexe, j'ai listé les différents blocs par ordre d'importance et par ordre d'apparition
Et là, on s'aperçoit qu'il y a des blocs de plus de 25 lignes
Cela n'a peut-être peu d'importance pour le traitement mais je pense qu'il est bon de le savoir
Après tout, je n'ai peut-être pas encore pigé comment on définissait ces fameux blocs
Si ça peut faire avancer dans la suite de l'analyse, voici le code, parce que j'ai l'impression que le chemin va être long
Option Explicit
Sub les_blocs1()
Dim i As Long, ii As Long, j As Long, n As Long, SL As Object, pStack As Object
Set SL = CreateObject("System.Collections.SortedList")
Set pStack = CreateObject("System.Collections.Stack")
Application.ScreenUpdating = False
With Sheets("lg RaptorXX")
For i = .Cells(.Rows.Count, "g").End(xlUp).Row To 2 Step -1
If .Cells(i, 3).Value <> 0 Then
j = 1
Do Until .Cells(i, 7) <> .Cells(i, 7)(j)
'If Not pStack.Contains(.Cells(i, 3)(j).Value) Then
pStack.Push .Cells(i, 3)(j).Value
'End If
j = j - 1
Loop
If Not SL.Contains(pStack.Count) Then
Set SL(pStack.Count) = _
CreateObject("System.Collections.SortedList")
End If
SL(pStack.Count)(i + j) = pStack.ToArray()
pStack.Clear
i = i + j
End If
Next i
End With
On Error Resume Next
Application.DisplayAlerts = False
Sheets("Blocs").Delete
Sheets.Add().Name = "Blocs"
On Error GoTo 0
With Sheets("Blocs")
n = 1
For i = 0 To SL.Count - 1
With .Cells(n, 1)
.Value = "Bloc de " & SL.GetKey(i) & " lignes"
.Interior.ColorIndex = 44
.BorderAround Weight:=xlThin
End With
For ii = 0 To SL.GetByIndex(i).Count - 1
With .Cells(n, 2)
.Value = "ligne " & SL.GetByIndex(i).GetKey(ii)
.Interior.ColorIndex = 19
.BorderAround Weight:=xlThin
End With
With .Cells(n, 3).Resize(UBound(SL.GetByIndex(i).GetByIndex(ii)) + 1)
.Value = Application.Transpose(SL.GetByIndex(i).GetByIndex(ii))
.BorderAround Weight:=xlThin
End With
n = n + UBound(SL.GetByIndex(i).GetByIndex(ii)) + 1
Next
n = n + 1
Next
With .UsedRange
.VerticalAlignment = xlCenter
.Columns(1).ColumnWidth = 16
.Columns(2).ColumnWidth = 13
.Columns(3).NumberFormat = "0"
.Columns("a:c").Font.Size = 10
End With
End With
Set SL = Nothing: Set pStack = Nothing
Application.ScreenUpdating = True
End Subedit : j'ai à peu près pigé les différents scénarios curulis57, en attendant les autres
klin89
Bonjour Klin89, et Curulis57
Merci à Klin89 de rejoindre l'aventure (Je répondrai a ton code ultèrieurement car je ne l'ai pas testé à l'instant T et je m'en excuse )
Pour revenir au code de Curulis57 j'ai traité 14 Dossiers ce week-End et j'ai trouvé comment procédé en toute sécurité
Le code doit traiter Scénario 1 puis Scénario 2 séparément avec l'aide d'un Pop-Up
En double cliquant sur la feuille = Pop-up "Quel Scénario à appliquer : 1? 2?"
Choix1 Scénario 1 apliquer sur tout les onglets "lg" existant du classeur avec effacement des lignes à "0"
si des blocks non traiter = popup qui indique les lignes non reconstitués pour action "Correction Manuel"
Choix2 Scénario 2 s'applique sur tout les onglets "lg" existant du classeur (dépourvu des "0" du scénario 1 traité précedemment)
si des blocks non traiter = popup qui indique les lignes non reconstitués pour action "Correction Manuel"
On évite ainsi la collusion entre scenario1 et scenario2
ci-joint un fichier Test F23 vierge de traitement qui embarque le dernier code de Curulis57
Je vous souhaite un trés bon réveillon et de profiter de ce dernier jour de 2018 comme il ce doit avec beaucoup Joie et de santé et l'accomplissement de vos souhaits les plus ambitieux.
Bien cordialement et Merci pour votre implications et votre déterminations
Daniel
Bonjour,
Mes meilleurs vœux de bonheurs santés et prospérités à vous et vos familles en cette nouvelle année 2019.
Que cette nouvelle année soit riches en évênements positifs pour pour notre planête et nos enfants.
Que le meilleurs !!!!!!!!!!
Klin89 j'ai regardé ta macro et elle est vraiment orienté Blocks, mais en l'état elle n'est pas explicit dépourvu des colonnes E et G qui représentent les actions pour une séquence donné.
Exemple : séquences Peintures pour une piece donné les actions sont = Anti Corrosion + Séchage + Anti Réflectivité + Séchage2 + Anti Raisonnance + Séchage 3 + Couleur + Séchage 4 + couche hydrophobe + séchage 5
Donc normal de trouvé des blocks > 25
Curculis57 est parti sur une approche plus en adéquation et surtout qu'il à mis en évidence une faille chez nous
qui a conduit au rajout du scénario2 et encore une fois avec son coup d'oeil averti il à soulevé une probable collusion entre le Scénario 1 et scénario 2 d'ou ma demande de traiter séparément les scénarios que l'ai émis dans mon post précédent
Merci d'avance à vous deux pour vos Lumières !!!!!!!!!!
Daniel
Bonjour Curulis57,
Merci à toi d'avoir apporter ce projet au niveau ou il est aujourd'hui. Je suis conscient que ma dernière requête
repose sur tes épaules Expert, mais sache ma reconnaissance pour ton niveau et ton travail sur le sujet.
Par avance Merci Curulis57 de ton support et aide
Bien cordialement
Salut Barachoie,
après les quelques jours chaotiques de fin d'année, je reprends le collier ce soir.
Tu auras certainement un fichier demain.
A+
... processing ...
Possible de m'envoyer un fichier avec deux feuilles de données non traitées?
(Attention à la limite du Méga!)
Salut Barachoie,
Un double-clic en [D:M] dans n'importe quelle feuille démarre la macro ;
- elle te demande dans une InputBox quel scénario tu veux jouer :
* 1 ( scénario 1 seul )
* 2 ( scénario 2 seul ) ATTENTION : PAS DE PROTECTION SI LE SCENARIO 1 N'A PAS ÉTÉ EXÉCUTÉ AVANT ;
* 3 ( scénario 1 et 2 à la volée ) ;
- tu peux cliquer "Annuler" ou taper 0 pour annuler ;
Pour conserver tes couleurs, je ne peux pas travailler avec des tableaux (pas vraiment encore cherché non plus) donc, il faut un peu de temps pour mouliner tes 15000 lignes X 2 feuilles.
En fin de traitement :
Une feuille RECAP est créée et placée après les autres où s'affiche par feuille les emplacements des blocs à corriger manuellement.
Dans 'RECAP' :
- un double-clic en [B-C-D] t'emmène à l'emplacement précisé par les données.
Dans la feuille de ton choix :
- double-clic en [A Scénario 1] ou [B Scénario 2] = recherche du premier bloc du scénario corrigé BLANC GRAS en italique pour le scénario 2 ;
- clic-droit en [A Scénario 1] ou [B Scénario 2] = recherche du premier bloc du scénario à corriger manuellement ROUGE GRAS en italique pour le scénario 2 ;
- pour passer au bloc suivant, même clic sous le bloc en cours.
J'en suis là pour l'instant.
J'imagine que lors d'une correction, tu remets les lignes corrigées en NOIR NORMAL ?
Peux-tu décrire ce que tu fais que je puisse te proposer un traitement automatique de remise en forme des polices (noir normal) ?
A tester.
A te lire.
A+
Curulis57 tout d'abord bonjour et Merci !!!!
Désolé de te répondre si tardivement car pb familial et là je suis loin de chez moi
Mon Excel installé ne permet pas lire le format de ton dernier fichier il fait que du xlsm xls xlb (2003)
Pour te répondre sur la couleur de Ligne et bien le blanc restera car ça permet de voir les corrections effectué par ta
Macro et que ces onglets corrigés seront traités par 2 autres application derriere (déjà fonctionnels) qui traitent sans
distinction.
Le déroulement des scénarios + Récap comme tu me le décrit me semble PARFAIT !!!!! j'ai hâte de le voir à l'Oeuvre.
Garder les couleurs de fond différent pour chaque action est aujourd'hui volontaire pour servir de détrompeur le temps de le faire vivre....
Une fois mature pour gagner en temps de traitement il faudra probablement ce résigné à passer en mode tableau et/ou traitement global de A-Z
Encore MERCI à toi tu fais un boulot de ouf et l'étendus de ta maitrise d'Excel me laisse simplement admiratif depuis de début et c'est grandiose
Bien Cordialement et Respectueux de ton Art!!!
Curulis57 bonjour,
Le lien me donne bien accès a un fichier mais corrompu ou endommagé donc Excel ne le lie pas
Pourrais-tu s'il te plait me fournir le fichier sans données à part ta Macro comme ça je pourrai le testé sur
mes données du jour.
Je t'en serai infiniment reconnaissant
Bonne après-midi à toi et encore Merci pour ton support
Salut Barachoie,
bizarre, je charge le fichier sans souci...
Le code est à coller dans le module VBA de 'ThisWorbook'.
Private Sub Workbook_SheetBeforeRightClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean)
'
Dim iRowA&
'
Cancel = True
Application.EnableEvents = False
Application.ScreenUpdating = False
'
If Not Intersect(Target, Range("A:B")) Is Nothing Then Call FindBlocs(ActiveSheet.Index, Target.Row, Target.Column, 2)
'
Application.EnableEvents = True
Application.ScreenUpdating = True
'
End Sub
Private Sub Workbook_SheetBeforeDoubleClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean)
'
Dim tData, tData1, tData2(), iSh%, iOK%, iRowA&, iNb%, iFlag%, sMsg$
'
Cancel = True
Application.EnableEvents = False
Application.ScreenUpdating = False
'
Select Case Sh.Name
Case "RECAP"
If Target <> "" Then _
iTRow = Target.Row: _
iRowA = Sh.Range("C" & iTRow).Value: _
sMsg = IIf(Target.Offset(-1, 0) = "", Sh.Range("A" & iTRow).Value, Sh.Range("A" & Target.End(xlUp).Row).Value): _
Worksheets(sMsg).Activate: _
ActiveWindow.ScrollRow = iRowA
Case Else
If Not Intersect(Target, Sh.Range("A:B")) Is Nothing Then Call FindBlocs(ActiveSheet.Index, Target.Row, Target.Column, 1)
'
If Not Intersect(Target, Sh.Range("D:M")) Is Nothing Then
Do
iRep = Application.InputBox("Scénarii : 1 / 2 / 3 (1 et 2)", "SCAN SCENARII", "3", Type:=1)
Loop Until iRep >= 0 And iRep <= 3
If iRep > 0 Then
iStart = 0
If Sheets(Sheets.Count).Name <> "RECAP" Then Worksheets.Add(after:=Sheets(Sheets.Count)).Name = "RECAP"
For iSh = 1 To Sheets.Count - 1
If UCase(Left(Sheets(iSh).Name, 2)) = "LG" Then
With Sheets(iSh)
For iScan = IIf(iRep = 2, 2, 1) To IIf(iRep = 1, 1, 2)
On Error Resume Next
.Columns("A:A").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
On Error GoTo 0
iRowA = .Range("A" & Rows.Count).End(xlUp).Row
For x = iRowA To 2 Step -1
iOK = 0
Select Case iScan
Case 1
If CInt(.Cells(x, 3)) = 0 And (CInt(.Cells(x, 4)) <> CInt(.Cells(x + 1, 4)) And x + 1 <= iRowA) Then
iNb = CInt(.Cells(x, 12))
iOK = 1
End If
Case 2
If CInt(.Cells(x, 3)) > 0 And CInt(.Cells(x - 1, 3)) = 0 And CInt(.Cells(x, 11)) = 1 Then
iNb = CInt(.Cells(x, 3))
.Rows(x - 1).Delete shift:=xlUp
x = x - 1
iOK = 1
End If
End Select
'
If iOK = 1 Then
'Insertion des lignes nécessaires
If iNb > 1 Then _
.Rows(x + 1 & ":" & x + (iNb - 1)).Insert shift:=xlDown: _
.Range("A" & x & ":M" & x + (iNb - 1)).FillDown: _
tData = .Range("C" & x & ":C" & x + (iNb - 1)).Value
'
'Recherche d'un bloc si iNb < 25
If iNb > 1 And iNb < 25 Then
For y = x + iNb To .Range("A" & Rows.Count).End(xlUp).Row
If CInt(.Cells(y, 12)) = iNb And CInt(.Cells(y, 3)) > 0 Then _
iOK = y: _
tData1 = .Range("C" & y & ":C" & y + (iNb - 1)).Value: _
Exit For
Next
'Si bloc < 25 non-trouvé
If iOK = 1 Then _
iFlag = iFlag + 1: _
ReDim Preserve tData2(4, iFlag): _
If iFlag - 1 = iStart Then tData2(0, iFlag - 1) = Sheets(iSh).Name: _
tData2(1, iFlag - 1) = iScan: _
tData2(2, iFlag - 1) = x - IIf(iScan = 1, (iNb - 1), (iNb - 2)): _
tData2(3, iFlag - 1) = iNb
End If
'Actualisation des n° de lignes pour blocs < 25 non-trouvés
If iFlag > 0 Then
For y = iStart To iFlag - 1
tData2(2, y) = tData2(2, y) + IIf(iScan = 1, (iNb - 1), (iNb - 2))
Next
End If
'
'Initialisation des données en colonne [C]
If iNb > 1 Then
For y = 1 To UBound(tData, 1)
If iOK = 1 Then tData(y, 1) = y
If iOK > 1 Then tData(y, 1) = CInt(tData1(y, 1))
Next
End If
'
'Affichage et coloration en blanc gras
.Range("A" & x & ":M" & x + (iNb - 1)).Font.Bold = True
If iNb > 1 Then .Range("C" & x & ":C" & x + (iNb - 1)).Value = tData
If iScan = 2 Then .Range("A" & x & ":M" & x + (iNb - 1)).Font.Italic = True
.Range("A" & x & ":M" & x + (iNb - 1)).Font.Color = IIf(iOK = 1 And iNb > 1 And iNb < 25, RGB(255, 0, 0), RGB(255, 255, 255))
End If
Next
Union(.Range("B:B"), .Range("C:C"), .Range("D:D"), .Range("K:K"), .Range("L:L")).NumberFormat = "0"
.Columns.AutoFit
Next
If iFlag > 0 Then iFlag = iFlag + 1
iStart = iFlag
End With
End If
Next
If iFlag > 0 Then
With Worksheets("RECAP")
.Cells.ClearContents
.Range("E1").Value = "BLOCS A INITIALISER MANUELLEMENT"
.Range("A2").Value = "Fichier"
.Range("B2").Value = "Scénario"
.Range("C2").Value = "Ligne"
.Range("D2").Value = "Bloc"
.Range("A4").Resize(iFlag, 4).Value = WorksheetFunction.Transpose(tData2)
.Range("B:D").NumberFormat = "0"
.Columns("A:D").AutoFit
.Activate
End With
Else
MsgBox "Aucun bloc ne doit être réinitialisé manuellement !", vbInformation + vbOKOnly, "Scenarii"
Sheets(1).Activate
End If
End If
End If
End Select
'
Application.ScreenUpdating = True
Application.EnableEvents = True
'
End Sub
Public Sub FindBlocs(ByVal iSheet, iTRow, iTCol, iIdx)
'
With Sheets(iSheet)
iRowA = .Range("A" & Rows.Count).End(xlUp).Row
For x = iTRow To iRowA
If .Cells(x, 1).Font.Bold = True And .Cells(x, 1).Font.Italic = IIf(iTCol = 1, False, True) And .Cells(x, 1).Font.Color = IIf(iIdx = 1, RGB(255, 255, 255), RGB(255, 0, 0)) Then _
ActiveWindow.ScrollRow = x: _
Exit For
Next
End With
'
End SubA+
Curulis57 bonsoir et Merci...
Comment te dire ça ...
Pour moi tu fais parti des meilleurs Développeurs et tu es génial !!!!!!!!!
Je l'ai fait tourné sur deux onglets et c'est un florilège de Datas qui auparavant était mués....
Très belle réalisation et je t'en remercie infiniment
Salut Barachoie,
quasi ?
En outre, il reste des zéros qui traînent (scénario 2 mais [Kxx] > 1...
Quid ?
A+
Curulis57 bonjour,
Désolé ton travail est PARFAIT !!!!!!!
Le quasi vient de moi et uniquement moi car j'ai oublié la notion "d'Exeption"
Je m'explique : Dans la chaine de fabrication il y a des controles "HUMAINS" et ils sont 6 personnes seuls habilitées à controler. Ils sont identifié par 3 lettres et n° de certification secrets donc ne doivent pas apparaitre dans un rapport d'analyse et avec la multiplication des lignes ils apparaissent trop du fait qu'ils ne font pas du 100% mais de l'échantillonnage. (ils réceptionne bien 25 pièces mais n'en contrôle que 8)
Ma question
est-il possible que scenari 1 ou 2 ne fasse aucun traitement si en colonne G
j'ai *PAT* ou *CHS* ou *KYL* ou *FRE* ou *MAR* ou *KAT*
Merci pour ton aide précieux