Résolu XL 2016 Déplacer une ligne associée à un dossier

APPRENTI:)

XLDnaute Nouveau
Bonsoir à vous,

Force est de constater qu'il y a des personnes très compétentes sur ce forum, je reviens vous solliciter! :)

j'ai créé une base de données pour laquelle vous m'avez aidé à créer automatiquement un dossier nominatif pour chaque nouvel entrant.

Je souhaiterai avoir la possibilité de déplacer en même temps:
- La ligne qui correspondes au CHANTIER fini vers l'onglet BILANS (dans la base de données)
- Le dossier CHANTIER correspondant à cette ligne vers le dossier BILANS

exemple:
le chantier du nom de A est finit:
-La ligne dans la Base de Données du nom de A est déplacé dans l'onglet BILANS
-Le Dossier du nom de A se trouvant dans le dossier CHANTIER est déplacé dans le dossier BILAN

Merci encore !
 
Ce fil a été résolu! Aller à la solution…

Fichiers joints

job75

XLDnaute Barbatruc
Bonsoir APPRENTI,

Pour y comprendre quelque chose il faut donner le lien avec le fil d'origine :

https://www.excel-downloads.com/threads/creation-de-dossiers-a-partir-dune-base-de-donnees.20043418/

Sélectionnez par exemple le nom "A" et cliquez sur le bouton "Bilans".

La macro du bouton "Bilans", voyez le fichier .xlsm joint :
VB:
Sub Bilans()
Dim lig&, i&, fso As Object, chemin$, dossier1$, dossier2$, dossier3$, dossier4$
Feuil1.Activate 'CodeName
lig = ActiveCell.Row
If lig < 3 Or Cells(lig, 1) = "" Or Cells(lig, 3) = "" Then Exit Sub
'---transfert de la ligne---
With Sheets("Bilans")
    If .FilterMode Then .ShowAllData 'si la feuille est filtrée
    i = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
    Cells(lig, 1).Resize(, 21).Copy .Cells(i, 1) 'pour les formats
    .Cells(i, 1).Resize(, 21) = Cells(lig, 1).Resize(, 21).Value 'copie les valeurs
    .Visible = xlSheetVisible 'si la feuille est masquée
    Application.Goto .[A1], True 'cadrage
    .Parent.Save 'enregistre le fichier
End With
'---transfert du dossier dans le dossier BILAN---
Set fso = CreateObject("Scripting.FileSystemObject")
chemin = ThisWorkbook.Path & "\"
dossier1 = chemin & UCase(Cells(lig, 1))
dossier2 = dossier1 & " TYPE"
dossier3 = dossier1 & "\" & Cells(lig, 3)
dossier4 = chemin & "BILAN"
If Dir(dossier1, vbDirectory) = "" Then MkDir dossier1 'crée le dossier s'il n'existe pas
If Dir(dossier2, vbDirectory) = "" Then MkDir dossier2 'crée le dossier s'il n'existe pas
If Dir(dossier3, vbDirectory) = "" Then fso.copyfolder dossier2, dossier3 'copie et crée le dossier s'il n'existe pas
If Dir(dossier4, vbDirectory) = "" Then MkDir dossier4 'crée le dossier BILAN s'il n'existe pas
fso.copyfolder dossier3, dossier4 & "\" & Cells(lig, 3) 'transfert
End Sub
Bonne nuit.

Edit : j'ai effacé la somme en Q468 et modifié la formule en R3 =Q3/SOMME(Q:Q)
 

Fichiers joints

Dernière édition:

APPRENTI:)

XLDnaute Nouveau
Bonsoir APPRENTI,

Pour y comprendre quelque chose il faut donner le lien avec le fil d'origine :

https://www.excel-downloads.com/threads/creation-de-dossiers-a-partir-dune-base-de-donnees.20043418/

Sélectionnez par exemple le nom "A" et cliquez sur le bouton "Bilans".

La macro du bouton "Bilans", voyez le fichier .xlsm joint :
VB:
Sub Bilans()
Dim lig&, i&, fso As Object, chemin$, dossier1$, dossier2$, dossier3$, dossier4$
Feuil1.Activate 'CodeName
lig = ActiveCell.Row
If lig < 3 Or Cells(lig, 1) = "" Or Cells(lig, 3) = "" Then Exit Sub
'---transfert de la ligne---
With Sheets("Bilans")
    If .FilterMode Then .ShowAllData 'si la feuille est filtrée
    i = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
    Cells(lig, 1).Resize(, 21).Copy .Cells(i, 1) 'pour les formats
    .Cells(i, 1).Resize(, 21) = Cells(lig, 1).Resize(, 21).Value 'copie les valeurs
    .Visible = xlSheetVisible 'si la feuille est masquée
    Application.Goto .[A1], True 'cadrage
    .Parent.Save 'enregistre le fichier
End With
'---transfert du dossier dans le dossier BILAN---
Set fso = CreateObject("Scripting.FileSystemObject")
chemin = ThisWorkbook.Path & "\"
dossier1 = chemin & UCase(Cells(lig, 1))
dossier2 = dossier1 & " TYPE"
dossier3 = dossier1 & "\" & Cells(lig, 3)
dossier4 = chemin & "BILAN"
If Dir(dossier1, vbDirectory) = "" Then MkDir dossier1 'crée le dossier s'il n'existe pas
If Dir(dossier2, vbDirectory) = "" Then MkDir dossier2 'crée le dossier s'il n'existe pas
If Dir(dossier3, vbDirectory) = "" Then fso.copyfolder dossier2, dossier3 'copie et crée le dossier s'il n'existe pas
If Dir(dossier4, vbDirectory) = "" Then MkDir dossier4 'crée le dossier BILAN s'il n'existe pas
fso.copyfolder dossier3, dossier4 & "\" & Cells(lig, 3) 'transfert
End Sub
Bonne nuit.

Edit : j'ai effacé la somme en Q468 et modifié la formule en R3 =Q3/SOMME(Q:Q)
Boujour à tous!!!!

Merci à toi Job 75!!!! :D

Est il possible d'effacer la ligne dans la base de données et le dossier nominatif dans CHANTIER en même temps?

Très bonne journée :)
 

job75

XLDnaute Barbatruc
Est il possible d'effacer la ligne dans la base de données et le dossier nominatif dans CHANTIER en même temps?
Fichier (2) avec la macro modifiée :
VB:
Sub Bilans()
Dim lig&, i&, tablo, fso As Object, chemin$, dossier1$, dossier2$, dossier3$, dossier4$
Feuil1.Activate 'CodeName
lig = ActiveCell.Row
If lig < 3 Or Cells(lig, 1) = "" Or Cells(lig, 3) = "" Then Exit Sub
Application.ScreenUpdating = False
'---transfert de la ligne---
With Sheets("Bilans")
    If .FilterMode Then .ShowAllData 'si la feuille est filtrée
    i = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
    Cells(lig, 1).Resize(, 21).Copy .Cells(i, 1) 'pour les formats
    tablo = Cells(lig, 1).Resize(, 21) 'mémorise les valeurs
    .Cells(i, 1).Resize(, 21) = tablo 'copie les valeurs
    Cells(lig, 1).Resize(, 21).Delete xlUp 'supprime la ligne
    .Parent.RefreshAll 'actualise le TCD
    .Visible = xlSheetVisible 'si la feuille est masquée
    Application.Goto .[A1], True 'cadrage
    .Parent.Save 'enregistre le fichier
End With
'---transfert du dossier dans le dossier BILAN---
Set fso = CreateObject("Scripting.FileSystemObject")
chemin = ThisWorkbook.Path & "\"
dossier1 = chemin & UCase(tablo(1, 1))
dossier2 = dossier1 & " TYPE"
dossier3 = dossier1 & "\" & tablo(1, 3)
dossier4 = chemin & "BILAN"
If Dir(dossier1, vbDirectory) = "" Then MkDir dossier1 'crée le dossier s'il n'existe pas
If Dir(dossier2, vbDirectory) = "" Then MkDir dossier2 'crée le dossier s'il n'existe pas
If Dir(dossier3, vbDirectory) = "" Then fso.CopyFolder dossier2, dossier3 'copie et crée le dossier s'il n'existe pas
If Dir(dossier4, vbDirectory) = "" Then MkDir dossier4 'crée le dossier BILAN s'il n'existe pas
fso.CopyFolder dossier3, dossier4 & "\" & tablo(1, 3) 'transfert
fso.DeleteFolder dossier3 'supprime le dossier
End Sub
 
Ce message a été identifié comme étant une solution!

Fichiers joints

APPRENTI:)

XLDnaute Nouveau
C'est magnifique!!!
C'est propre!!! Quand bien même je ne comprends pas tout…..!!
un grand merci à toi Job 75 :)
 

Créez un compte ou connectez vous pour répondre

Vous devez être membre afin de pouvoir répondre ici

Créer un compte

Créez un compte Excel Downloads. C'est simple!

Connexion

Vous avez déjà un compte? Connectez vous ici.

Haut Bas