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

APPRENTI:) · 1 Avril 2020

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 !

job75 · 2 Avril 2020

APPRENTI:) à dit:
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...

job75 · 2 Avril 2020

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)

APPRENTI:) · 2 Avril 2020

job75 à dit:

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

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 · 2 Avril 2020

APPRENTI:) à dit:
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

APPRENTI:) · 2 Avril 2020

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

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

APPRENTI:)

XLDnaute Nouveau

Pièces jointes

job75

job75

XLDnaute Barbatruc

Pièces jointes

APPRENTI:)

XLDnaute Nouveau

job75

XLDnaute Barbatruc

Pièces jointes

APPRENTI:)

XLDnaute Nouveau

Discussions similaires