Problème copier des données sur une feuil puis les coller sur une autre

[gymgazelle]

Bonjour, j'ai effectué une macro grâce a de l'aide pour copier/coller.
mais je n'arrive pas à la modifier pour qu'elle puisse sélectionner toutes les données pour les coller dans une autre feuille.

merci de votre aide

 

[vgendron]

Hello
un essai avec ce code

Sub macro2()

Dim TabData() As Variant
Dim TabFinal() As Variant
Dim Tab1() As Variant
Dim Tab2() As Variant

With Sheets("BDD")
    Nbl = .Range("B" & .Rows.Count).End(xlUp).Row - 3
    TabData = .Range("B4:E" & Nbl + 3).Value
    ReDim TabFinal(1 To 2 * Nbl, 1 To 4)
End With
With Sheets("Tableaux")
    .Range("Tableau1").ClearContents
    .Range("Tableau2").ClearContents
   
    Tab1 = .Range("Tableau1").Value
    Tab2 = .Range("Tableau2").Value
End With

For i = LBound(TabData, 1) To UBound(TabData, 1)
    'MsgBox UBound(TabFinal, 1)
    TabFinal(i, 1) = TabData(i, 1)
   
    TabFinal(i + Nbl, 1) = TabData(i, 4)
    TabFinal(i, 4) = TabData(i, 2)
    TabFinal(i + Nbl, 4) = TabData(i, 3)
Next i

For i = LBound(TabFinal, 1) To UBound(TabFinal, 1)
    If i <= 15 Then
        For j = 1 To 4
            Tab1(i, j) = TabFinal(i, j)
        Next j
    Else
        For j = 1 To 4
            Tab2(i - 15, j) = TabFinal(i, j)
        Next j
    End If
Next i

With Sheets("Tableaux")
    .Range("Tableau1") = Tab1
    .Range("Tableau2") = Tab2
End With
End Sub

 

[gymgazelle]

Bonjour,

je viens d'essayer et une erreur apparaît. Apres, il faut que je respecte le nom des plages car là c'est un exemple. Le tableau n'est pas constitue comme celui-ci.
Merci

 

[job75]

Bonjour gymgazelle, vgendron,

Vous écrivez "ainsi que "soir" mais en dessous", ce n'est pas très clair, d'après ce que je comprends :

Sub Macro1()
Dim Col1 As Range, Col2 As Range, Col3 As Range, Col4 As Range
Dim F As Worksheet, i As Byte, T As Range, h As Long
Set Col1 = [masj]: Set Col2 = [pj] 'plages nommées
Set Col3 = [soir]: Set Col4 = [psoir] 'plages nommées
Application.ScreenUpdating = False
Set F = Workbooks.Add.Sheets(1) 'document auxiliaire
Col1.Copy F.[A1]
Col3.Copy F.Range("A" & F.Rows.Count).End(xlUp)(2)
Set Col1 = F.[A:A] 'redéfinition
Col2.Copy F.[B1]
Col4.Copy F.Range("B" & F.Rows.Count).End(xlUp)(2)
Set Col2 = F.[B:B] 'redéfinition
With Feuil2 'CodeName de la feuille
    For i = 1 To 2 '2 tableaux nommés
        Set T = .Range("Tableau" & i)
        T.Columns(1) = Col1.Resize(T.Rows.Count).Offset(h).Value 'copie les valeurs
        T.Columns(4) = Col2.Resize(T.Rows.Count).Offset(h).Value 'copie les valeurs
        h = h + T.Rows.Count
        If Application.CountA(T) Then
            .PageSetup.PrintArea = T.EntireColumn _
                .Resize(T.EntireColumn.Find("*", , xlValues, , xlByRows, xlPrevious).Row).Address
            .PrintPreview 'aperçu avant impression pour tester
            '.PrintOut 'pour imprimer
        End If
    Next
End With
F.Parent.Close False 'fermeture du document auxiliaire
End Sub

Edit : simplifié les redéfinitions de Col1 et Col2 (colonnes entières).

Fichier (2) joint.

A+

 

[gymgazelle]

Merci
ça à l'air d’être ça.

je vais tester

 

[gymgazelle]

Bonjour,

c'est super mais quand je le met sur 2007 mon aperçu avant impression ne fonctionne pas correctement, je n'ai pas le ruban qui correspond.
et- je ne peux pas masquer les lignes vides.

pourquoi alors que sur 2010 ça à l'air de bien fonctionné.
je te joins une copie du fichier.

 

[job75]

Bonjour gymgazelle,

Comme il y a maintenant des formules (RECHERCHEV) dans vos tableaux utilisez :

Sub macro2()

Dim Col1 As Range, Col2 As Range, Col11 As Range, Col12 As Range
Dim F As Worksheet, i As Byte, T As Range, h As Long
Set Col1 = [masj]: Set Col2 = [pjour] 'plages nommées
Set Col11 = [soir]: Set Col12 = [psoir] 'plages nommées
Application.ScreenUpdating = False
Set F = Workbooks.Add.Sheets(1) 'document auxiliaire
Col1.Copy F.[A1]
Col11.Copy F.Range("A" & F.Rows.Count).End(xlUp)(2)
Set Col1 = F.Range("A1", F.Range("A" & F.Rows.Count).End(xlUp)) 'redéfinition
Col2.Copy F.[B1]
Col12.Copy F.Range("B" & F.Rows.Count).End(xlUp)(2)
Set Col2 = F.Range("B1", F.Range("B" & F.Rows.Count).End(xlUp)) 'redéfinition
With Feuil4 'CodeName de la feuille
    .Activate
    For i = 1 To 2 '2 tableaux nommés
        Set T = .Range("Tableau" & i)
        T.Columns(1) = Col1.Offset(h).Resize(T.Rows.Count).Value 'copie les valeurs
        T.Columns(4) = Col2.Offset(h).Resize(T.Rows.Count).Value 'copie les valeurs
        h = h + T.Rows.Count
        If Application.CountA(T.Columns(1), T.Columns(4)) Then
            .PageSetup.PrintArea = T.EntireColumn.Resize(Union(T.Columns(1), T.Columns(4)) _
                .EntireColumn.Find("*", , xlValues, , xlByRows, xlPrevious).Row).Address
            .PrintPreview 'aperçu avant impression pour tester
            '.PrintOut 'pour imprimer
        End If
    Next
    F.Parent.Close False 'fermeture du document auxiliaire
End With
End Sub

Pour Excel 2007 je ne peux faire mieux, éventuellement supprimez Application.ScreenUpdating = False.

Fichier joint.

A+

 

[gymgazelle]

Merci,
je l’ai testé, mais pour imprimer j’ai dû activé printout et qui fonctionne que si on fait La Croix pour fermer et ça imprime.
On ne peut pas afficher le ruban de l’apercu avant impression.
Sinon ça a l’air super comme ça fonctionne
Merci de ton aide