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.
 

Pièces jointes

  • Base de données.xlsx
    98.4 KB · Affichages: 11
  • Carnets-bord-2019.xlsm
    51.7 KB · Affichages: 2
Dernière édition:

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
 

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+
 

Pièces jointes

  • Carnets bord(1).xlsm
    60.9 KB · Affichages: 5
  • Base de données.xlsx
    9.9 KB · Affichages: 6

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
 

Pièces jointes

  • Base de données(1).xlsm
    22.2 KB · Affichages: 9
  • Carnets bord.xlsx
    48.7 KB · Affichages: 11

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?
 

Pièces jointes

  • Base de données.xlsm
    30.5 KB · Affichages: 7

Discussions similaires

Statistiques des forums

Discussions
311 720
Messages
2 081 923
Membres
101 840
dernier inscrit
SamynoT