Gwendoline
XLDnaute Junior
Bonjour,
J'ai créé un VBA pour me faire des onglets par personne. Cela fonctionne quand je démarre le VBA depuis ALT+F11 mais quand j'applique la VBA dans une macro, cela ne fonctionne pas correctement.
Résultat : elle supprime plus de colonne que j'ai souhaitées.
J'ai beau cherché, je ne vois pas où j'ai fauté.
Votre aide sera très utile.
Merci
J'ai créé un VBA pour me faire des onglets par personne. Cela fonctionne quand je démarre le VBA depuis ALT+F11 mais quand j'applique la VBA dans une macro, cela ne fonctionne pas correctement.
Résultat : elle supprime plus de colonne que j'ai souhaitées.
J'ai beau cherché, je ne vois pas où j'ai fauté.
Votre aide sera très utile.
Merci
VB:
Sub OngletManager()
Dim DLig As Long, DCol As Integer
Dim Mondico As Object
Dim aa As String, bb As String
Dim J As Long
Dim Tablo
Application.ScreenUpdating = False
' Partie distribution des infos
Set Mondico = CreateObject("Scripting.Dictionary")
With Sheets("_Data")
DLig = .Range("A" & Rows.Count).End(xlUp).Row 'Compter le nombre de lignes dans _Data
DCol = Cells(1, Columns.Count).End(xlToLeft).Column 'Compter le nombre de colonnes dans _Data
For J = 2 To DLig
Mondico(.Range("A" & J).Value) = .Range("A" & J).Value
Next J
Tablo = Mondico.Items
For J = 0 To Mondico.Count - 1
aa = Tablo(J)
If FeuilleExiste(CStr(Tablo(J))) = False Then
Sheets.Add after:=Sheets(Sheets.Count)
ActiveSheet.Name = (aa)
.Range(.Cells(1, 1), .Cells(1, DCol)).Copy Destination:=ActiveSheet.Range("A5")
ElseIf FeuilleExiste(aa) = True And Not IsEmpty(Sheets(aa).Range("A6")) Then
Sheets(aa).Range("A6:Q" & DLig).ClearContents
End If
Next J
For k = 2 To DLig
bb = .Cells(k, 1)
.Range(.Cells(k, 1), .Cells(k, DCol)).Copy Destination:=Sheets(bb).Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
Next k
End With
'Mise en forme des colonnes
For Z = 5 To Mondico.Count + 4
Sheets(Z).Select
Range("C:D").Delete
Range("D:D").Delete
Range("F:J").Delete
Cells.EntireColumn.AutoFit
'Collage spécial
Range("A1:M100").Copy
Range("A1:M100").PasteSpecial (xlPasteValues)
Range("A1").Select
With ActiveWindow
.DisplayGridlines = False
End With
Next Z
Application.ScreenUpdating = True
End Sub
Function FeuilleExiste(nom As String) As Boolean
On Error Resume Next
FeuilleExiste = Sheets(nom).Name <> ""
On Error GoTo 0
End Function