XL 2019 Récupération valeurs d'un fichier vers un autre vba

sylvanu à dit:

Bonsoir Quicksland,
Un essai en PJ à tester.
La macro à lancer est "Importer"
A noter qu'il y aura surement un problème de février année bissextile vers année non bissextile.

Cliquez pour agrandir...

Quicksland à dit:

"N4 " du " fichier pot " vers "C4" du fichier " prix de revient "

Cliquez pour agrandir...

sylvanu à dit:

Oups! C'est comme à l'école : quand tu lis mal les consignes, t'as une gamelle ! 😅
Il suffit de remplacer

VB:

Sheets(F.Name).Range("N4:C" & NL).PasteSpecial xlPasteValues
par
Sheets(F.Name).Range("C4:C" & DL).PasteSpecial xlPasteValues

Cliquez pour agrandir...

sylvanu à dit:

Bonsoir,
Il vous suffit d'adapter le code.
Pour transférer d'une colonne à une autre il suffit de faire par ex de C4 vers C4 :

VB:

DL = Sheets(F.Name).Range("C65500").End(xlUp).Row - 1
.Range("C4:C" & DL).Copy

Et recopier ces deux lignes pour vos 5 transferts.

Cliquez pour agrandir...

DL = Sheets(F.Name).Range("E65500").End(xlUp).Row - 1
                .Range("C4:C" & DL).Copy
                Sheets(F.Name).Range("C4:C" & DL).PasteSpecial xlPasteValues

Quicksland à dit:

Cela donne ça alors ?

Cliquez pour agrandir...

sylvanu à dit:

Oui, et vous répétez pour les 5 colonnes.

Cliquez pour agrandir...

Private Sub CommandButton2_Click()

    Application.ScreenUpdating = False
    NomFichier = "GESTION - POTS.xlsm"
    FichierCourant = ThisWorkbook.Name
    Workbooks.Open ThisWorkbook.Path & "\" & NomFichier
    Workbooks(FichierCourant).Activate
    For Each F In Worksheets
        If Sheets(F.Name).[E2] = "Coût solide / Prestation" Then
            With Workbooks(NomFichier).Sheets(F.Name)
                DL = Sheets(F.Name).Range("E65500").End(xlUp).Row - 1
                .Range("C4:C" & DL).Copy
                Sheets(F.Name).Range("C4:C" & DL).PasteSpecial xlPasteValues
                .Range("E4:E" & DL).Copy
                Sheets(F.Name).Range("E4:E" & DL).PasteSpecial xlPasteValues
                .Range("F4:F" & DL).Copy
                Sheets(F.Name).Range("F4:F" & DL).PasteSpecial xlPasteValue
                 .Range("G4:G" & DL).Copy
                Sheets(F.Name).Range("G4:G" & DL).PasteSpecial xlPasteValue
                .Range("H4:H" & DL).Copy
                Sheets(F.Name).Range("H4:H" & DL).PasteSpecial xlPasteValue
        
            End With
        End If
    Next F
    Application.CutCopyMode = False
    Workbooks(NomFichier).Close Savechanges:=False
End Sub

sylvanu à dit:

Bonsoir,
Dans l'ordre,
1- Par sécurité je vérifier que sur la feuille en E2 il y avait "Coût solide / Prestation" .
maintenant ce n'est plus le cas, donc ça ne pouvait pas marcher. J'ai remplacé par "Format".
2- Comme les colonnes sont vides, DL vaut 2, et avec C4:C2 ça ne marche pas.
J'ai rajouté :

VB:

If DL < 4 Then DL = 4

3- C'est inutile de recopier le code sur toutes les pages, c'est source d'erreur en cas de maintenance, on est sur d'oublier une page.
Donc dans chaque page j'ai mis :

Code:

Private Sub CommandButton2_Click()
    Importer
End Sub

Et en macro classique :

Code:

Sub Importer()
    Application.ScreenUpdating = False
    NomFichier = "GESTION - POTS.xlsm"
    FichierCourant = ThisWorkbook.Name
    Workbooks.Open ThisWorkbook.Path & "\" & NomFichier
    Workbooks(FichierCourant).Activate
    For Each F In Worksheets
        If Sheets(F.Name).[E2] = "Format" Then
            With Workbooks(NomFichier).Sheets(F.Name)
                DL = Sheets(F.Name).Range("E65500").End(xlUp).Row - 1
                If DL < 4 Then DL = 4
                .Range("C4:C" & DL).Copy
                Sheets(F.Name).Range("C4:C" & DL).PasteSpecial xlPasteValues
                .Range("E4:E" & DL).Copy
                Sheets(F.Name).Range("E4:E" & DL).PasteSpecial xlPasteValues
                .Range("F4:F" & DL).Copy
                Sheets(F.Name).Range("F4:F" & DL).PasteSpecial xlPasteValues
                .Range("G4:G" & DL).Copy
                Sheets(F.Name).Range("G4:G" & DL).PasteSpecial xlPasteValues
                .Range("H4:H" & DL).Copy
                Sheets(F.Name).Range("H4:H" & DL).PasteSpecial xlPasteValues
            End With
        End If
    Next F
    Application.CutCopyMode = False
    Workbooks(NomFichier).Close Savechanges:=False
End Sub

Cliquez pour agrandir...