XL 2010 Transférer données d'un classeur vers un autre classeur avec condition

Fransez

XLDnaute Nouveau
Bonjour chère communauté,

Je vous sollicite car j'ai besoin d'une précieuse aide pour débuter en macro.

Mon problème est le suivant :

La macro que j'essaye de créer mais en vain doit transférer les lignes des deux onglets du classeur vers autre classeur.

Je vous remercie par avance.
 

Fichiers joints

Dernière édition:

Fransez

XLDnaute Nouveau
Bonjour fanfan,
Je te remercie pour ton retour et ta réactivité. Je vais me plonger dans ton code demain et je ne manquerai pas de te faire un retour. Je te souhaite une bonne fin de journée et à très vite
 

Fransez

XLDnaute Nouveau
Bonjour fanfan,

En exécutant ton code j'ai une erreur sur cette ligne :

'Initialisation du classeur destination
Set wkDestination = Workbooks("Base de données.xlsx")

Le fichier a pourtant bien le même nom. Est-ce que tu as une solution?

Je te remercie par avance.

Cordialement,

Bonne journée
 

Fransez

XLDnaute Nouveau
Bonjour fanfan,

Effectivement le code fonctionne quand le fichier est ouvert.

Je te remercie pour ton aide.

Cordialement
 

job75

XLDnaute Barbatruc
Bonjour Fransez, fanfan38,

Téléchargez les fichiers joints dans le même dossier (le bureau) et exécutez cette macro :
VB:
Sub Transfert()
'se lance par les touches Ctrl+T
Dim fichier$, an As Variant, ncol%, resu(), w As Worksheet, derlig&, tablo, i&, n&, j%
fichier = ThisWorkbook.Path & "\Base de données.xlsx" 'à adapter
If Dir(fichier) = "" Then MsgBox "'" & fichier & "' introuvable !", 48: Exit Sub
an = 2018 'année par défaut à adapter
ncol = 14 'nombre de colonnes, à adapter
Do
    an = Application.InputBox("Entrez l'année :", "Transfert", an)
    If an = False Then Exit Sub
Loop While Not an Like "####"
ReDim resu(1 To Rows.Count, 1 To ncol)
an = Val(an)
For Each w In ThisWorkbook.Worksheets
    If w.FilterMode Then w.ShowAllData 'si la feuille est filtrée
    derlig = w.Range("A" & w.Rows.Count).End(xlUp).Row
    If derlig > 6 Then
        tablo = w.Range("A7:A" & derlig).Resize(, ncol) 'matrice, plus rapide
        For i = 1 To UBound(tablo)
            If IsDate(tablo(i, 1)) And IsDate(tablo(i, 2)) Then
                If Not (Year(tablo(i, 1)) > an Or Year(tablo(i, 2)) < an) Then
                    n = n + 1
                    For j = 1 To ncol
                        resu(n, j) = tablo(i, j)
                    Next j
                End If
            End If
        Next i
    End If
Next w
'---restitution---
Application.ScreenUpdating = False
Application.DisplayAlerts = False 'si le fichier est déjà ouvert
With Workbooks.Open(fichier).Sheets(1)
    If .FilterMode Then .ShowAllData 'si la feuille est filtrée
    With .[A2] 'adapter éventuellement
        If n Then
            .Resize(n, ncol) = resu
            .Resize(n, ncol).Borders.Weight = xlThin 'bordures
            .Resize(n, ncol).Columns(ncol) = "=G2+N(N1)"
        End If
        .Cells(0, 1).Resize(n + 1, ncol).Sort .Cells(1), xlAscending, Header:=xlYes 'tri
        .Offset(n).Resize(.Parent.Rows.Count - n - .Row + 1, ncol).Delete xlUp 'RAZ en dessous
    End With
    With .UsedRange: End With 'actualise les barres de défilement
End With
End Sub
L'exécution est très rapide car on utilise des tableaux VBA.

Les MFC en colonnes L et N ont été revues.

A+
 

Fichiers joints

Fransez

XLDnaute Nouveau
Bonjour job,

Excellent boulot! Je te remercie pour ton retour.

J'essaye de modifier la macro pour l’exécuter du classeur "Base de données" plutôt que du classeur "Carnet de bord".

Est-ce que tu as une piste ou c'est trop contraignant en terme de manipulation?

Bien à toi!

Bonjour Fransez, fanfan38,

Téléchargez les fichiers joints dans le même dossier (le bureau) et exécutez cette macro :
VB:
Sub Transfert()
'se lance par les touches Ctrl+T
Dim fichier$, an As Variant, ncol%, resu(), w As Worksheet, derlig&, tablo, i&, n&, j%
fichier = ThisWorkbook.Path & "\Base de données.xlsx" 'à adapter
If Dir(fichier) = "" Then MsgBox "'" & fichier & "' introuvable !", 48: Exit Sub
an = 2018 'année par défaut à adapter
ncol = 14 'nombre de colonnes, à adapter
Do
    an = Application.InputBox("Entrez l'année :", "Transfert", an)
    If an = False Then Exit Sub
Loop While Not an Like "####"
ReDim resu(1 To Rows.Count, 1 To ncol)
an = Val(an)
For Each w In ThisWorkbook.Worksheets
    If w.FilterMode Then w.ShowAllData 'si la feuille est filtrée
    derlig = w.Range("A" & w.Rows.Count).End(xlUp).Row
    If derlig > 6 Then
        tablo = w.Range("A7:A" & derlig).Resize(, ncol) 'matrice, plus rapide
        For i = 1 To UBound(tablo)
            If IsDate(tablo(i, 1)) And IsDate(tablo(i, 2)) Then
                If Not (Year(tablo(i, 1)) > an Or Year(tablo(i, 2)) < an) Then
                    n = n + 1
                    For j = 1 To ncol
                        resu(n, j) = tablo(i, j)
                    Next j
                End If
            End If
        Next i
    End If
Next w
'---restitution---
Application.ScreenUpdating = False
Application.DisplayAlerts = False 'si le fichier est déjà ouvert
With Workbooks.Open(fichier).Sheets(1)
    If .FilterMode Then .ShowAllData 'si la feuille est filtrée
    With .[A2] 'adapter éventuellement
        If n Then
            .Resize(n, ncol) = resu
            .Resize(n, ncol).Borders.Weight = xlThin 'bordures
            .Resize(n, ncol).Columns(ncol) = "=G2+N(N1)"
        End If
        .Cells(0, 1).Resize(n + 1, ncol).Sort .Cells(1), xlAscending, Header:=xlYes 'tri
        .Offset(n).Resize(.Parent.Rows.Count - n - .Row + 1, ncol).Delete xlUp 'RAZ en dessous
    End With
    With .UsedRange: End With 'actualise les barres de défilement
End With
End Sub
L'exécution est très rapide car on utilise des tableaux VBA.

Les MFC en colonnes L et N ont été revues.

A+
Bonjour Fransez, fanfan38,

Téléchargez les fichiers joints dans le même dossier (le bureau) et exécutez cette macro :
VB:
Sub Transfert()
'se lance par les touches Ctrl+T
Dim fichier$, an As Variant, ncol%, resu(), w As Worksheet, derlig&, tablo, i&, n&, j%
fichier = ThisWorkbook.Path & "\Base de données.xlsx" 'à adapter
If Dir(fichier) = "" Then MsgBox "'" & fichier & "' introuvable !", 48: Exit Sub
an = 2018 'année par défaut à adapter
ncol = 14 'nombre de colonnes, à adapter
Do
    an = Application.InputBox("Entrez l'année :", "Transfert", an)
    If an = False Then Exit Sub
Loop While Not an Like "####"
ReDim resu(1 To Rows.Count, 1 To ncol)
an = Val(an)
For Each w In ThisWorkbook.Worksheets
    If w.FilterMode Then w.ShowAllData 'si la feuille est filtrée
    derlig = w.Range("A" & w.Rows.Count).End(xlUp).Row
    If derlig > 6 Then
        tablo = w.Range("A7:A" & derlig).Resize(, ncol) 'matrice, plus rapide
        For i = 1 To UBound(tablo)
            If IsDate(tablo(i, 1)) And IsDate(tablo(i, 2)) Then
                If Not (Year(tablo(i, 1)) > an Or Year(tablo(i, 2)) < an) Then
                    n = n + 1
                    For j = 1 To ncol
                        resu(n, j) = tablo(i, j)
                    Next j
                End If
            End If
        Next i
    End If
Next w
'---restitution---
Application.ScreenUpdating = False
Application.DisplayAlerts = False 'si le fichier est déjà ouvert
With Workbooks.Open(fichier).Sheets(1)
    If .FilterMode Then .ShowAllData 'si la feuille est filtrée
    With .[A2] 'adapter éventuellement
        If n Then
            .Resize(n, ncol) = resu
            .Resize(n, ncol).Borders.Weight = xlThin 'bordures
            .Resize(n, ncol).Columns(ncol) = "=G2+N(N1)"
        End If
        .Cells(0, 1).Resize(n + 1, ncol).Sort .Cells(1), xlAscending, Header:=xlYes 'tri
        .Offset(n).Resize(.Parent.Rows.Count - n - .Row + 1, ncol).Delete xlUp 'RAZ en dessous
    End With
    With .UsedRange: End With 'actualise les barres de défilement
End With
End Sub
L'exécution est très rapide car on utilise des tableaux VBA.

Les MFC en colonnes L et N ont été revues.

A+
 

job75

XLDnaute Barbatruc
Pourquoi avez-vous supprimé les 2 fichiers du post #1 ???
J'essaye de modifier la macro pour l’exécuter du classeur "Base de données" plutôt que du classeur "Carnet de bord".
L'adaptation n'est pas très difficile :
VB:
Sub Transfert()
'se lance par les touches Ctrl+T
Dim fichier$, an As Variant, ncol%, resu(), w As Worksheet, derlig&, tablo, i&, n&, j%
fichier = ThisWorkbook.Path & "\Carnets bord.xlsx" 'à adapter
If Dir(fichier) = "" Then MsgBox "'" & fichier & "' introuvable !", 48: Exit Sub
an = 2018 'année par défaut à adapter
ncol = 14 'nombre de colonnes, à adapter
Do
    an = Application.InputBox("Entrez l'année :", "Transfert", an)
    If an = False Then Exit Sub
Loop While Not an Like "####"
ReDim resu(1 To Rows.Count, 1 To ncol)
an = Val(an)
Application.ScreenUpdating = False
Application.DisplayAlerts = False 'si le fichier est déjà ouvert
With Workbooks.Open(fichier)
    For Each w In .Worksheets
        If w.FilterMode Then w.ShowAllData 'si la feuille est filtrée
        derlig = w.Range("A" & w.Rows.Count).End(xlUp).Row
        If derlig > 6 Then
            tablo = w.Range("A7:A" & derlig).Resize(, ncol) 'matrice, plus rapide
            For i = 1 To UBound(tablo)
                If IsDate(tablo(i, 1)) And IsDate(tablo(i, 2)) Then
                    If Not (Year(tablo(i, 1)) > an Or Year(tablo(i, 2)) < an) Then
                        n = n + 1
                        For j = 1 To ncol
                            resu(n, j) = tablo(i, j)
                        Next j
                    End If
                End If
            Next i
        End If
    Next w
    .Close False 'fermeture du fichier
End With
'---restitution---
With ThisWorkbook.Sheets(1)
    If .FilterMode Then .ShowAllData 'si la feuille est filtrée
    With .[A2] 'adapter éventuellement
        If n Then
            .Resize(n, ncol) = resu
            .Resize(n, ncol).Borders.Weight = xlThin 'bordures
            .Resize(n, ncol).Columns(ncol) = "=G2+N(N1)"
        End If
        .Cells(0, 1).Resize(n + 1, ncol).Sort .Cells(1), xlAscending, Header:=xlYes 'tri
        .Offset(n).Resize(.Parent.Rows.Count - n - .Row + 1, ncol).Delete xlUp 'RAZ en dessous
    End With
    With .UsedRange: End With 'actualise les barres de défilement
End With
End Sub
 

Fichiers joints

Fransez

XLDnaute Nouveau
Je te remercie pour ton retour. Pas très facile tu es d’une efficacité redoutable .
Désolé pour la suppression du fichier j’ai du faire une fausse manipulation. Je vais les remettre dans le message initial.
 

Fransez

XLDnaute Nouveau
Pourquoi avez-vous supprimé les 2 fichiers du post #1 ???

L'adaptation n'est pas très difficile :
VB:
Sub Transfert()
'se lance par les touches Ctrl+T
Dim fichier$, an As Variant, ncol%, resu(), w As Worksheet, derlig&, tablo, i&, n&, j%
fichier = ThisWorkbook.Path & "\Carnets bord.xlsx" 'à adapter
If Dir(fichier) = "" Then MsgBox "'" & fichier & "' introuvable !", 48: Exit Sub
an = 2018 'année par défaut à adapter
ncol = 14 'nombre de colonnes, à adapter
Do
    an = Application.InputBox("Entrez l'année :", "Transfert", an)
    If an = False Then Exit Sub
Loop While Not an Like "####"
ReDim resu(1 To Rows.Count, 1 To ncol)
an = Val(an)
Application.ScreenUpdating = False
Application.DisplayAlerts = False 'si le fichier est déjà ouvert
With Workbooks.Open(fichier)
    For Each w In .Worksheets
        If w.FilterMode Then w.ShowAllData 'si la feuille est filtrée
        derlig = w.Range("A" & w.Rows.Count).End(xlUp).Row
        If derlig > 6 Then
            tablo = w.Range("A7:A" & derlig).Resize(, ncol) 'matrice, plus rapide
            For i = 1 To UBound(tablo)
                If IsDate(tablo(i, 1)) And IsDate(tablo(i, 2)) Then
                    If Not (Year(tablo(i, 1)) > an Or Year(tablo(i, 2)) < an) Then
                        n = n + 1
                        For j = 1 To ncol
                            resu(n, j) = tablo(i, j)
                        Next j
                    End If
                End If
            Next i
        End If
    Next w
    .Close False 'fermeture du fichier
End With
'---restitution---
With ThisWorkbook.Sheets(1)
    If .FilterMode Then .ShowAllData 'si la feuille est filtrée
    With .[A2] 'adapter éventuellement
        If n Then
            .Resize(n, ncol) = resu
            .Resize(n, ncol).Borders.Weight = xlThin 'bordures
            .Resize(n, ncol).Columns(ncol) = "=G2+N(N1)"
        End If
        .Cells(0, 1).Resize(n + 1, ncol).Sort .Cells(1), xlAscending, Header:=xlYes 'tri
        .Offset(n).Resize(.Parent.Rows.Count - n - .Row + 1, ncol).Delete xlUp 'RAZ en dessous
    End With
    With .UsedRange: End With 'actualise les barres de défilement
End With
End Sub
Après adaptation qu'est ce que tu en penses Job?
 

Fichiers joints

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