Macro pour ajout total et enregistrement dans chemin d'accès dynamique

Bonjour à tous.

j'utilise powerquery pour obtenir le résultat en PJ.

je souhaiterais créer une macro qui ajoute :

  • la cellule I2 (ecritures a passer) dans la 1ere cellule vide de la colonne A de l'onglet 4009
  • la cellule I3 (ecritures a passer) dans la 1ere cellule vide de la colonne A de l'onglet 4016
  • la cellule I4 (ecritures a passer) dans la 1ere cellule vide de la colonne A de l'onglet 4075
  • la cellule I5 (ecritures a passer) dans la 1ere cellule vide de la colonne A de l'onglet 4004
  • la cellule I6 (ecritures a passer) dans la 1ere cellule vide de la colonne A de l'onglet 4449
  • la cellule H2 (ecritures a passer) dans la 1ere cellule vide de la colonne D de l'onglet 4009
  • la cellule H3(ecritures a passer) dans la 1ere cellule vide de la colonne D de l'onglet 4016
  • la cellule H4 (ecritures a passer) dans la 1ere cellule vide de la colonne D de l'onglet 4075
  • la cellule H5 (ecritures a passer) dans la 1ere cellule vide de la colonne D de l'onglet 4004
  • la cellule H6 (ecritures a passer) dans la 1ere cellule vide de la colonne D de l'onglet 4449

Puis cette macro devrait enregistrer chaque onglet ( 4009, 4016, 4075 et 4004) en autant de fichiers avec l'extension .xls

je souhaiterais que le nom de chaque fichier soit aussi dynamique :

pour 4009 : il porterait le nom : 2019.11.27 FICHIER 1 FACTURES NIK REMISE France (cellule I2 de l'onglet date fichiers)

pour 4016 : il porterait le nom : 2019.11.27 FICHIER 1 FACTURES EIK REMISE France (cellule J2 de l'onglet date fichiers)

pour 4075 : il porterait le nom : 2019.11.27 FICHIER 1 FACTURES CIK REMISE France (cellule K2 de l'onglet date fichiers)

pour 4004 : il porterait le nom : 2019.11.27 FICHIER 1 FACTURES OIK REMISE France (cellule L2 de l'onglet date fichiers)

pour 4449 : il porterait le nom : 2019.11.27 FICHIER 1 FACTURES XOB REMISE France (cellule M2 de l'onglet date fichiers)

Il faudrait que ces fichiers aillent s'enregistrer automatiquement dans le chemin suivant :

\Mes Documents\TEST

puis qu'ils aillent automatiquement dans le dossier 2019 lorsque la cellule G2 de l'onglet date fichiers = 2019 ou dans le dossier 2020 lorsque la cellule G2 de l'onglet date fichiers = 2020 ....

puis aillent dans le sous dossier NIK pour l'onglet 4009, EIK pour l'onglet 4016, CIK pour l'onglet 4075, OIK pour l'onglet 4004 et XOB pour l'onglet 4449

Pouvez vous m'aider ?

merci bcp par avance.

9test.xlsx (22.15 Ko)

Bonjour Ben68500,

Si j'ai bien compris tes problématiques, je te propose le code VBA suivant :

Option Explicit
Sub Completer_Dispatcher()
    'Nom de la feuille maitresse
    Const cFromSheetName = "Ecritures à passer"
    'Nom de la feuille Date
    Const cDateSheetName = "Dates fichiers"
    'Plage à explorer dans la feuille maitresse
    Const cPlage = "$G$2:$J$6"
    'Adresse de la cellule contenant l'année
    Const cAnnee = "$G$2"

    Dim oTargetWB As Workbook
    Dim oFromSheet As Worksheet, oToSheet As Worksheet
    Dim oFromRange As Range, oRow As Range, oCell As Range
    Dim oFS As Object

    Dim lLastRow As Long, sToSheetName As String
    Dim sAnnee As String, sPath As String, sFileName As String
    Dim sNom As String

    'On affecte les variables objets
    Set oFromSheet = ThisWorkbook.Worksheets(cFromSheetName)
    Set oFromRange = oFromSheet.Range(cPlage)
    Set oFS = CreateObject("Scripting.FileSystemObject")

    'On récupère l'année
    sAnnee = CStr(ThisWorkbook.Worksheets(cDateSheetName).Range(cAnnee).Value)

    'On explore toutes les lignes de la plage
    For Each oRow In oFromRange.Rows
        'On récupère le nom de la feuille à compléter
        sToSheetName = Trim(CStr(oRow.Cells(1, 1).Value))
        'On s'assure que la feuille existe
        If sheetExists(sToSheetName) Then
            'On complète la feuille
            Set oToSheet = ThisWorkbook.Worksheets(sToSheetName)
            'On recherche la dernière ligne de la feuille
            lLastRow = oToSheet.Cells(Rows.Count, 1).End(xlUp).Row

            'Si la dernière ligne n'a pas déjà été renseignée, on la créé
            If oToSheet.Cells(lLastRow, 1).Value <> oRow.Cells(1, 3).Value Then
                'On recopie le nb de factures
                oToSheet.Cells(lLastRow + 1, 1).Value = oRow.Cells(1, 3).Value

                'On recopie le montant fichier
                oToSheet.Cells(lLastRow + 1, 4).Value = oRow.Cells(1, 2).Value
            End If

            'On recherche le nom du sous-dossier
            sNom = oRow.Cells(1, 4).Value
            'On compose le nom du dossier cible
            sPath = CreateObject("WScript.Shell").SpecialFolders("mydocuments") & "\TEST\" & sNom & "\" & sAnnee
            'On controle que le dossier cible existe, sinon, on le crée
            If Not oFS.FolderExists(sPath) Then
                CreateFolder oFS, sPath
            End If
            'On récupère le nom du fichier EXCEL à créer
            sFileName = ""
            For Each oCell In ThisWorkbook.Worksheets(cDateSheetName).UsedRange.Rows(1).Cells
                'Lorsque l'on retrouve le nom
                If oCell.Value = sNom Then
                    'on prend le nom de fichier dans la ligne suivante et on sort de la boucle
                    sFileName = Replace(oCell.Offset(1).Value, ".", "_")
                    Exit For
                End If
            Next

            'On controle que le nom de fichier a été trouvé
            If Len(sFileName) > 0 Then
                'On copie la feuille courante
                oToSheet.Copy
                'On créé le classeur cible
                Set oTargetWB = ActiveWorkbook
                'On sauve le classeur cible dans le bon dossier et avec le bon nom
                oTargetWB.SaveAs sPath & "\" & sFileName & ".xlsx"
                'On ferme le classeur cible
                oTargetWB.Close False
            Else
                MsgBox "Aucun nom de fichier correspondant à '" & sNom & "'" & vbCrLf & vbCrLf & "Copie non réalisée!"
            End If
        End If
    Next

End Sub
Function sheetExists(zSheetName As String) As Boolean
    Dim oSheet As Worksheet
    On Error GoTo dontExists
    Set oSheet = ThisWorkbook.Worksheets(zSheetName)
    sheetExists = True
    Exit Function
dontExists:
    sheetExists = False
End Function
Sub CreateFolder(zFS As Object, zPath As String)
    Dim aSubfolders() As String, i As Integer
    Dim sFolder As String

    aSubfolders() = Split(zPath, "\")
    sFolder = aSubfolders(0)
    For i = 1 To UBound(aSubfolders)
        sFolder = sFolder & "\" & aSubfolders(i)
        If Not zFS.FolderExists(sFolder) Then
            zFS.CreateFolder (sFolder)
        End If
    Next
End Sub

Comme tu le constateras dans mon classeur de test que je joints, j'ai apporté quelques modifications dans la feuille "Ecritures à passer":

  • J'ai ajouté un bouton pour le déclenchement de la procédure " Completer_Dispatcher"
  • J'ai ajouté une colonne "Sous dossier" pour y stocker le nom des sous-dossiers des sociétés.
11test-gvs.xlsm (42.28 Ko)
Rechercher des sujets similaires à "macro ajout total enregistrement chemin acces dynamique"