Option Explicit Public Sub traitement() Dim c As Range, derlig As Long, i As Long, ou As Long, enA As String, taborig derlig = Worksheets("BD").Range("B" & Rows.Count).End(xlUp).Row If derlig < 8 Then MsgBox "pas de données à traiter !": Exit Sub taborig = Worksheets("BD").Range("A8:L" & derlig) For Each c In Worksheets("entreprises").Range("A:A").SpecialCells(xlCellTypeConstants) If c.Text <> "" Then With Worksheets(c.Value) .Range(.Cells(7, 1), .Cells(Rows.Count, Columns.Count)).ClearContents ' on vide chaque feuille après ligne 7 End With End If Next For i = 1 To UBound(taborig) With Worksheets(taborig(i, 2)) ou = ou_ecrire(Worksheets(taborig(i, 2))) enA = taborig(i, 4) & Chr(10) & taborig(i, 8) & Chr(10) & taborig(i, 12) enA = Replace(enA, Chr(10) & Chr(10), Chr(10)) .Range("A" & ou).Value = enA .Range("B" & ou).Value = taborig(i, 2) .Range("C" & ou).Value = taborig(i, 3) .Range("D" & ou).Value = taborig(i, 5) .Range("E" & ou).Value = taborig(i, 6) .Range("F" & ou).Value = taborig(i, 7) .Range("G" & ou).Value = taborig(i, 9) .Range("H" & ou).Value = taborig(i, 10) .Range("I" & ou).Value = taborig(i, 11) End With Next End Sub Private Function ou_ecrire(f As Worksheet) As Long ou_ecrire = f.Range("A" & Rows.Count).End(xlUp).Row + 1 If ou_ecrire <7 Then ou_ecrire 7 End Function
Vous n’avez pas trouvé la réponse que vous recherchez ?
Posez votre questionSub Macro2() Dim bd As Object 'déclare la variable bd (onglet BD) Dim dico As Object 'déclare la variable dico (DICtiOnnaire) Dim dl As Integer 'déclare la variable dl (Dernière Ligne) Dim pl As Range 'déclare la variable pl (PLage) Dim cel As Range 'déclare la variable cel (CELlule) Dim temp As Variant 'déclare la variable temp (tableau TEMPoraire) Dim i As Integer 'déclare la variable i (Incrément) Dim dics As Object 'déclare la variable dics (DICtionnaireS) Dim o As Object 'déclare la variable o (Onglet) Dim dest As Range 'déclare la variable dest (cellule de DESTination) Dim teo As Variant 'déclare le tableau de variables teo (tableau TEmporaire Outils) Dim x As Integer 'déclare la variable x Dim y As Integer 'déclare la variable y Dim dercol As Integer Set bd = Sheets("ConsultCMDP") 'définit l'onglet bd Set dico = CreateObject("Scripting.Dictionary") 'définit le dictionnaire dico dl = bd.Cells(Application.Rows.Count, 1).End(xlUp).Row 'définit la dernière ligne éditée dl de la colonne 1 (=A) de l'onglet bd Set pl = bd.Range("B8:B" & dl) 'définit la plage pl bd.Range("A1").AutoFilter 'annule le filtre automatique For Each cel In pl 'boucle sur toutes les cellules cel de la plage pl dico(cel.Value) = "" 'alimente le dictionnaire dico Next cel 'prochaine cellule de la boucle temp = dico.keys 'récupère le dictionnaire sans doublon dans le tableau temp For i = 0 To UBound(temp) 'boucle 1 : sur toutes les valeurs uniques du tableau temp Set o = Sheets(temp(i)) 'définit l'onglet o o.Range("I2") = UCase(temp(i)) o.Range("I2").Font.ThemeColor = xlThemeColorDark1 o.Range("A5").CurrentRegion.ClearContents bd.Range("A1").AutoFilter 'lance le filtre automatique bd.Range("A1").AutoFilter field:=2, Criteria1:=temp(i) 'filtre automatique sur la colonne 2 (=B) avec la valeur temp(i) comme critère Set dics = CreateObject("Scripting.Dictionary") 'définit le dictionnaire dics For Each cel In pl.Offset(0, 1).SpecialCells(xlCellTypeVisible) 'boucle 2 : sur toutes les cellules visibles cel de la plage pl déclalée d'un colonne à droite dics(cel.Value) = "" 'alimente le dictionnaire dics Next cel 'prochaine cellule de la boucle 2 teo = dics.keys 'définit le tabeau teo y = 2 'initialise la variable y For x = 0 To UBound(teo) 'boucle 3 : sur toutes les outils (sans doublon) o.Cells(5, y + 2).Value = teo(x) 'place l'outil dans le tableau y = y + 2 'incrément y Next x 'prochain outil de la boucle 3 For Each cel In pl.Offset(0, 2).SpecialCells(xlCellTypeVisible) 'boucle 4 : sur toutes les cellules visibles cel de la plage pl déclalée de deux colonnes à droite If cel.Offset(0, 3) = "" Then Set dest = o.Range("A7").(o.Cells(Application.Rows.Count, 1).End(xlUp).Offset(1, 0)) 'définit la cellule de destination dest.Value = cel.Value 'récupère dans dest la valeur de la cellule cel (code initial) Next cel 'prochaine cellule de la boucle 4 bd.Range("A1").AutoFilter 'annule le filtre automatique Next i 'prochaine valeur de la boucle 1 End Sub
For Each cel In pl.Offset(0, 1).SpecialCells(xlCellTypeVisible)
- pour chaque entreprise, j'ai créé une feuille qui porte le nom de l'entreprise
Private Sub Worksheet_Change(ByVal Target As Range) Set encours = ActiveSheet If Target.Column <> 1 Or Target.Count > 1 Or Target.Value = "" Then Exit Sub On Error Resume Next xx = Worksheets(Target.Value).Name If Err <> 0 Then With Worksheets.Add .Name = Target.Value End With encours.Activate On Error GoTo 0 Else MsgBox "cette entreprise a déjà été créée !" Target.Value = "" End If End Sub Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Target.Column <> 1 Or Target.Count > 1 Then Exit Sub If Target.Value <> "" Then MsgBox "non modifiale" Target.Offset(0, 1).Activate End If End Sub
If Target.Column <> 1 Or Target.Count > 1 Or Target.Value = "" Then Exit Sub
Private encours As Range, quoi Private Sub ComboBox1_Click() If ComboBox1.ListIndex >= 0 Then encours.Value = ComboBox1.List(ComboBox1.ListIndex) End If ComboBox1.Visible = False End Sub Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Target.Column = 2 Then If ComboBox1.ListIndex < 0 And Not encours Is Nothing Then encours.Value = quoi End If derlig = Worksheets("entreprises").Range("A" & Rows.Count).End(xlUp).Row With ComboBox1 .ListFillRange = "entreprises!A1:A" & derlig .Top = Target.Top .Left = Target.Left .Height = Target.Height .Width = Target.Width .ListIndex = -1 .Visible = True End With Set encours = Target Else Set encours = Nothing End If End Sub