Fusionner deux macros ?

Le 23/02/2018 à 23:43

Bonsoir à tous,

Pourriez-vous m'aider à Adapter les deux macro dans un seule.

Code1

Option Explicit

Dim tablo, dico, i, j, k, t, ln, v(), fdep, f

Sub CréerLesDossiers()

    tablo = Range(Cells(1, 1), Cells(Range("A" & Rows.Count).End(xlUp).Row, Cells(1, Columns.Count).End(xlToLeft).Column))
    Set dico = CreateObject("Scripting.Dictionary")

    Set fdep = ActiveSheet
    Sheets.Add
    Set f = ActiveSheet
    fdep.Select

    For i = 2 To UBound(tablo, 1)
        dico(tablo(i, 1)) = ""
    Next i

    k = dico.keys
    For i = 0 To dico.Count - 1
        'MsgBox k(i)
        ln = 0
        For t = 2 To UBound(tablo, 1)
            If k(i) = tablo(t, 1) Then
                ReDim Preserve v(UBound(tablo, 2), ln + 1)
                For j = 1 To UBound(tablo, 2)
                    v(j - 1, ln) = tablo(t, j)
                Next j
                ln = ln + 1
            End If
        Next t

        f.Cells.Clear
        Rows("1:1").Copy f.Range("A1")
        f.Range("A2").Resize(UBound(v, 2), UBound(v, 1)) = Application.Transpose(v)

        f.Copy
        With ActiveWorkbook
            .SaveAs ThisWorkbook.Path & "\" & " " & k(i)
            .Close
        End With
    Next i

    'f.Cells.Clear
    f.Select
    Application.DisplayAlerts = False
    ActiveWindow.SelectedSheets.Delete
    MsgBox "Travail terminé."
End Sub

Sub Macro1()
'
' Macro1 Macro
'

'
    Sheets("Feuil7").Select
    ActiveWindow.SelectedSheets.Delete
End Sub

Code 2

Option Explicit

Sub CopPrincipale()
Dim Chemin As String, Fichier As String
Dim NbLg As Long

  Application.ScreenUpdating = False
  Chemin = ThisWorkbook.Path & Application.PathSeparator
  Fichier = "Principale_" & DatePart("ww", Date, vbMonday, vbFirstFourDays) + 1
  Sheets("Principale").Copy
  With ActiveWorkbook
    With .Sheets(1)
      NbLg = .Range("A" & Rows.Count).End(xlUp).Row
      .Range("A1:v" & NbLg).Copy
      .Range("A1").PasteSpecial Paste:=xlPasteValues
      .Range("D1:v" & NbLg).Copy
     ' .Range("D1").PasteSpecial Paste:=xlPasteValues
      '.Range("A1:B" & NbLg).Copy
      '.Range("A1").PasteSpecial Paste:=xlPasteValues
      .Range("A1").Select
    End With
    .SaveAs Chemin & Fichier & ".xlsx"
    .Close
  End With
  MsgBox "Fichier Copie Principale créé"
End Sub

Sub Coplistedesunites()
Dim Chemin As String, Fichier As String
Dim NbLg As Long

  Application.ScreenUpdating = False
  Chemin = ThisWorkbook.Path & Application.PathSeparator
  Fichier = "Unites_" & DatePart("ww", Date, vbMonday, vbFirstFourDays) + 1
  Sheets("Liste des unités").Copy
  With ActiveWorkbook
    With .Sheets(1)
      NbLg = .Range("A" & Rows.Count).End(xlUp).Row
      .Range("A1:k" & NbLg).Copy
      .Range("A1").PasteSpecial Paste:=xlPasteValues
      .Range("D1:k" & NbLg).Copy
     ' .Range("D1").PasteSpecial Paste:=xlPasteValues
      '.Range("A1:B" & NbLg).Copy
      '.Range("A1").PasteSpecial Paste:=xlPasteValues
      .Range("A1").Select
    End With
    .SaveAs Chemin & Fichier & ".xlsx"
    .Close
  End With
  MsgBox "Fichier Copie Liste des Unités créé"
End Sub

Sub Coplistedesfrns()
Dim Chemin As String, Fichier As String
Dim NbLg As Long

  Application.ScreenUpdating = False
  Chemin = ThisWorkbook.Path & Application.PathSeparator
  Fichier = "frns_" & DatePart("ww", Date, vbMonday, vbFirstFourDays) + 1
  Sheets("Liste des frns").Copy
  With ActiveWorkbook
    With .Sheets(1)
      NbLg = .Range("A" & Rows.Count).End(xlUp).Row
      .Range("A1:h" & NbLg).Copy
      .Range("A1").PasteSpecial Paste:=xlPasteValues
      .Range("D1:h" & NbLg).Copy
     ' .Range("D1").PasteSpecial Paste:=xlPasteValues
      '.Range("A1:B" & NbLg).Copy
      '.Range("A1").PasteSpecial Paste:=xlPasteValues
      .Range("A1").Select
    End With
    .SaveAs Chemin & Fichier & ".xlsx"
    .Close
  End With
  MsgBox "Fichier Copie Liste des frns créé"
End Sub

Sub Coplistedesarticles()
Dim Chemin As String, Fichier As String
Dim NbLg As Long

  Application.ScreenUpdating = False
  Chemin = ThisWorkbook.Path & Application.PathSeparator
  Fichier = "Articles_" & DatePart("ww", Date, vbMonday, vbFirstFourDays) + 1
  Sheets("Liste des articles").Copy
  With ActiveWorkbook
    With .Sheets(1)
      NbLg = .Range("A" & Rows.Count).End(xlUp).Row
      .Range("A1:h" & NbLg).Copy
      .Range("A1").PasteSpecial Paste:=xlPasteValues
      .Range("D1:h" & NbLg).Copy
     ' .Range("D1").PasteSpecial Paste:=xlPasteValues
      '.Range("A1:B" & NbLg).Copy
      '.Range("A1").PasteSpecial Paste:=xlPasteValues
      .Range("A1").Select
    End With
    .SaveAs Chemin & Fichier & ".xlsx"
    .Close
  End With
  MsgBox "Fichier Copie Liste des articles créé"
End Sub

Sub Coplistedesinducteurs()
Dim Chemin As String, Fichier As String
Dim NbLg As Long

  Application.ScreenUpdating = False
  Chemin = ThisWorkbook.Path & Application.PathSeparator
  Fichier = "Inducteurs_" & DatePart("ww", Date, vbMonday, vbFirstFourDays) + 1
  Sheets("Liste des inducteurs").Copy
  With ActiveWorkbook
    With .Sheets(1)
      NbLg = .Range("A" & Rows.Count).End(xlUp).Row
      .Range("A1:h" & NbLg).Copy
      .Range("A1").PasteSpecial Paste:=xlPasteValues
      .Range("D1:h" & NbLg).Copy
     ' .Range("D1").PasteSpecial Paste:=xlPasteValues
      '.Range("A1:B" & NbLg).Copy
      '.Range("A1").PasteSpecial Paste:=xlPasteValues
      .Range("A1").Select
    End With
    .SaveAs Chemin & Fichier & ".xlsx"
    .Close
  End With
  MsgBox "Fichier Copie Liste des inducteurs créé"
End Sub

Sub CoplisteSOP()
Dim Chemin As String, Fichier As String
Dim NbLg As Long

  Application.ScreenUpdating = False
  Chemin = ThisWorkbook.Path & Application.PathSeparator
  Fichier = "SOP_" & DatePart("ww", Date, vbMonday, vbFirstFourDays) + 1
  Sheets("Liste SOP").Copy
  With ActiveWorkbook
    With .Sheets(1)
      NbLg = .Range("A" & Rows.Count).End(xlUp).Row
      .Range("A1:B" & NbLg).Copy
      .Range("A1").PasteSpecial Paste:=xlPasteValues
      .Range("D1:P" & NbLg).Copy
     ' .Range("D1").PasteSpecial Paste:=xlPasteValues
      '.Range("A1:B" & NbLg).Copy
      '.Range("A1").PasteSpecial Paste:=xlPasteValues
      .Range("A1").Select
    End With
    .SaveAs Chemin & Fichier & ".xlsx"
    .Close
  End With
  MsgBox "Fichier Copie Liste SOP créé"
End Sub

Sub CoplisteContrats()
Dim Chemin As String, Fichier As String
Dim NbLg As Long

  Application.ScreenUpdating = False
  Chemin = ThisWorkbook.Path & Application.PathSeparator
  Fichier = "Contrats_" & DatePart("ww", Date, vbMonday, vbFirstFourDays) + 1
  Sheets("Liste des contrats").Copy
  With ActiveWorkbook
    With .Sheets(1)
      NbLg = .Range("A" & Rows.Count).End(xlUp).Row
      .Range("A1:h" & NbLg).Copy
      .Range("A1").PasteSpecial Paste:=xlPasteValues
      .Range("D1:h" & NbLg).Copy
     ' .Range("D1").PasteSpecial Paste:=xlPasteValues
      '.Range("A1:B" & NbLg).Copy
      '.Range("A1").PasteSpecial Paste:=xlPasteValues
      .Range("A1").Select
    End With
    .SaveAs Chemin & Fichier & ".xlsx"
    .Close
  End With
  MsgBox "Fichier Copie Liste des contrats créé"
End Sub

Je veux que les classeurs qui vont être crée par le code 1 ont dedans le résultat de code 2

Je vous remercie a tous pour vos réponses.

10copie-de-fiche-compte-v2-test005.xlsm (67.05 Ko)
10copie-de-testfeuille-test001.xlsm (23.87 Ko)
Le 24/02/2018 à 14:02

Oh ! quel joli code VBA !!! bien long, non indenté, non mis entre balises de code, et insipide à souhait !!!

Bonjour quand même, youssefoujd ! pour mettre ton code avec une présentation plus correcte, tu dois utiliser le 5ème bouton situé juste au-dessus du bord haut de la fenêtre où tu tapes ton message, celui avec ce dessin : « </> »

screen

Tu devrais aussi indiquer quelle est ton erreur de compilation (message d'erreur exact), et sur quelle ligne de code elle se produit (c'est la ligne de code VBA qui est mise en jaune).

Au hasard : c'est p't'être tout bêtement que t'as mal orthographié un nom de feuille, donc pour VBA, cette feuille est introuvable !!!

vérifie aussi si tu n'as pas un nom de variable mal orthographié ; nombreuses autres causes possibles : à toi de deviner !!!

dhany

Le 24/02/2018 à 14:19

Bravo pour avoir réussi à mettre ton code entre balises ! n'est-ce pas que c'est mieux présenté et plus digeste ?

Pour ta nouvelle demande, ce serait mieux de joindre un fichier : tu as le bouton nécessaire sous la fenêtre d'édition.

screen

Ta 1ère demande était pour résoudre une erreur de compilation ; cette 2ème demande est toute autre !

Je laisse à un autre intervenant le plaisir de réunir en une seule tes 2 macros ; bonne chance !

dhany

Rechercher des sujets similaires à "fusionner deux macros"