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.
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.