Insertion de lignes intuitive selon critères Phase1
Mesdames Messieurs j'ai entre les main un Challenge de taille. mes connaissances Excel sont pitoyable et je vous implore votre assistance
En effet j'ai un onglet de Datas Brut, et je voudrai créer un deuxièmes plus complet.
SI en colonne 'K' apparait le mot "SMIF" alors créer 'N' lignes supplémentaire au format exact d'un 'A' existant en Amont
pour compréhension je vous transmet un fichier avec 2 onglets Brut et résultat escompté
Par avance Merci infiniment de votre aide précieux
Bien cordialement
Bonsoir Lee, bonsoir le forum,
En pièce jointe ton fichier modifié avec le code ci-dessous. Clique sur le bouton Données.
Sub Macro1()
Dim OS As Worksheet 'déclare la variable OS (Onglet Source)
Dim OD As Worksheet 'déclare la variable OD (Onglet Destination)
Dim TV As Variant 'déclare la variable TV (Tableau des Valeurs)
Dim I As Integer 'déclare la variable I (Incrément)
Dim J As Integer 'déclare la variable J (incrément)
Dim DEST As Range 'déclare la variable DEST (cellule de DESTination)
Application.ScreenUpdating = False 'masque les rafraîchissements d'écran
Set OS = Worksheets("DATAS BRUT") 'définit l'onglet source OS
Set OD = Worksheets("ESCOMPTER") 'définit l'onglet destination OD
TV = OS.Range("A1").CurrentRegion 'définit le tableau des valeurs TV
OD.Range("A1").CurrentRegion.ClearContents 'efface les ancienne valeur de l'onlet OD
OD.Range("A1").Resize(1, UBound(TV, 2)).Value = Application.Index(TV, 1) 'renvoie la premièr eligne du tableau TV dans A1 redimensionnée de l'onglet OD
For I = 2 To UBound(TV, 1) 'boucle sur toutes les lignes I du tableau des valeurs TV (en partant de la seconde)
Set DEST = OD.Cells(Application.Rows.Count, "A").End(xlUp).Offset(1, 0) 'définit la cellule de destination DEST
If InStr(1, TV(I, 9), "SMIF") = 0 Then 'si "SMIF" n'appraît pas dans la donnée ligne I colonne 9 (=> coloone I)
DEST.Resize(1, UBound(TV, 2)).Value = Application.Index(TV, I) 'renvoie la ligne I de TV dans DEST redimensionnée
Else 'sinon (si SMIF" apparaît)
For J = 1 To TV(I, 14) + 1 'boucle de 1 à la valeur contenue dans la donnée ligne I colonne 14 (=> colonne N) plus une
DEST.Resize(1, UBound(TV, 2)).Value = Application.Index(TV, I) 'renvoie la ligne I de TV dans DEST redimensionnée
Select Case J 'agit en de J
Case 3 'cas 3
DEST.Offset(0, 1).Value = 3 'renvoie 3 dans la cellule DEST décalée d'une colonne à droite
DEST.Offset(0, 2).Value = 3 'renvoie 3 dans la cellule DEST décalée dde deux colonnes à droite
Case 4 ' cas 4
DEST.Offset(0, 1).Value = 2 'renvoie 2 dans la cellule DEST décalée d'une colonne à droite
DEST.Offset(0, 2).Value = 2 'renvoie 2 dans la cellule DEST décalée dde deux colonnes à droite
Case Else ' tous les autre cas
DEST.Offset(0, 1).Value = J - 1 'renvoie J - 1 dans la cellule DEST décalée dde deux colonnes à droite
DEST.Offset(0, 2).Value = J - 1 'renvoie J-1 dans la cellule DEST décalée dde deux colonnes à droite
End Select ' fin de l' action en fonction de J
Set DEST = DEST.Offset(1, 0) ' red'efinit la variable DEST (d'eclae d' un ligne vers le bas)
Next J ' prochaine valeur de J
End If ' fin de la condition
Next I ' prochaine ligne de la boucle
Application.ScreenUpdating = True 'afficheles rafraîchissements d'écran
OD.Activate 'active l'onglet OD
MsgBox "Données traités !" ' message
End SubLe fichier :
ThauThème Bonjour et Merci beaucoup pour ton essaie.
Il est déja trés probant et je t'en remercie car je sais que c'est beaucoup de temps et un domaine que tu métrises.
Je suis confronté à 1 points bloquant et 2 moindres.
1) Colonne B et C ne respecte pas les sequences changeant pour un "A" donnée.
En gardant la sequence initial sans cherchez la nouvelle pour chaque SMIF on s'expose a des datas erronées
car au fur et à mesure les SeriesID peuvent changé de place dans le fil du processus
exemple :
2) Est-il possible de laisser en Rouge Gras les lignes créées par ta Macro
Merci infiniment pour ton aide, car c'est puissant ce que tu fais là.
Bonjour,
Je tenais a remercier ThauThème pour son aide.
Est ce qu'il y a une solution de faisabilité ou pas je ne sais pas.
Merci d'avance au cador de ce forum de me porter leurs aide car c'est un vrai casse tête qui bloque considérablement mon projet.
Bien cordialement
MERCI
Bonjour le FORUM,
Je suis toujours dans l'impasse dans ce Post
Entre temps j'ai cherché mais le résultat semble capricieux.
Le code est mis dans le module thisworkbook et s'active par double click.
je veux rendre ce code plus intuitive et qui recherche vraiment les blocks existants selon un client donné.
Merci par avance de votre support précieux
Bien cordialement
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
'
If Not Intersect(Target, Range("A1")) Is Nothing Then
With Sh
For x = 1 To .Range("A" & Rows.Count).End(xlUp).Row
If Cells(x, 1).Font.Color = RGB(230, 0, 0) Then
ActiveWindow.ScrollRow = x
Exit For
End If
Next
End With
Else
For iSh = 1 To Sheets.Count
If UCase(Left(Sheets(iSh).Name, 3)) = "DAT" Then
With Sheets(iSh)
iFlag = 0
Erase tData2
iRowA = .Range("A" & Rows.Count).End(xlUp).Row
For x = iRowA - 1 To 2 Step -1
If .Cells(x, 3) = 0 And .Cells(x, 4) <> .Cells(x + 1, 4) Then
iOK = 0
iNb = .Cells(x, 14) - 1
'
'Insertion des lignes nécessaires
.Rows(x + 1 & ":" & x + iNb).Insert shift:=xlDown
.Range("A" & x & ":N" & x + iNb).FillDown
tData = .Range("C" & x & ":C" & x + iNb).Value
'
'Recherche d'un bloc si iNb < 25
If iNb < 24 Then
For Y = x + iNb + 1 To .Range("A" & Rows.Count).End(xlUp).Row
If CInt(.Cells(Y, 14)) = (iNb + 1) And CInt(.Cells(Y, 3)) > 0 Then
iOK = 1
tData1 = .Range("C" & Y & ":C" & Y + iNb)
Exit For
End If
Next
'Si bloc < 25 non-trouvé
If iOK = 0 Then
iFlag = iFlag + 1
ReDim Preserve tData2(2, iFlag)
tData2(1, iFlag - 1) = x - iNb
tData2(2, iFlag - 1) = iNb + 1
End If
End If
'Actualisation des n° de lignes pour blocs < 25 non-trouvés
If iFlag > 0 Then
For Y = 0 To iFlag - 1
tData2(1, Y) = tData2(1, Y) + iNb
Next
End If
'
'Initialisation des données en colonne [C]
For Y = 1 To UBound(tData, 1)
If iOK = 0 Then tData(Y, 1) = Y
If iOK > 0 Then tData(Y, 1) = CInt(tData1(Y, 1))
Next
'
'Affichage et coloration en blanc gras
.Range("C" & x & ":C" & x + iNb).Value = tData
.Range("A" & x & ":N" & x + iNb).Font.Bold = True
.Range("A" & x & ":N" & x + iNb).Font.Color = IIf(iOK = 0 And iNb < 24, RGB(230, 0, 0), RGB(230, 230, 230))
End If
Next
.Columns.AutoFit
End With
'
If iFlag > 0 Then
sMsg = sMsg & Sheets(iSh).Name & Chr(10)
For x = iFlag - 1 To 0 Step -1
sMsg = sMsg & tData2(1, x) & " - Bloc de " & tData2(2, x) & " lignes." & Chr(10)
Next
sMsg = sMsg & Chr(10)
End If
End If
Next
MsgBox sMsg, vbInformation + vbOKOnly, "Blocs non-réinitialisés"
Sheets(1).Activate
End If
'
Application.ScreenUpdating = True
Application.EnableEvents = True
'
End SubBonsoir le Forum,
Je fait appel à votre aide s'il vous plait pour savoir si mon projet est réalisable avec Excel, et si oui est ce je puis solliciter votre aide précieux.
Je sais que parmi vous il y a réellement des cadors sous Excel.
Par avance MERCI Infiniment
Cordialement