Ceci est une page optimisée pour les mobiles. Cliquez sur ce texte pour afficher la vraie page.

XL 2013 Ne pas copier les lignes complètes

Usine à gaz

XLDnaute Barbatruc
Supporter XLD
Bonjour à toutes et à tous,

ça fait longtemps et comme je vais mieux (pour l'instant), je me remets à l'amélioration de mes connaissances et, bien entendu, j'ai besoin de votre aide si précieuse.

Voici ma problématique :
J'ai un code que je pense avoir trouvé ici (comme d'hab )
Code: 
Sub Copie()
    Dim L As Long
    Dim LignesSel As Range
    For Each cel In Feuil1.Range("A2:A" & [A2].End(xlDown).Row)
        If cel.Value = "juju" Or cel.Value = "lola" Then
            If Not LignesSel Is Nothing Then
                Set LignesSel = Union(LignesSel, cel.EntireRow)
            Else
                Set LignesSel = cel.EntireRow
            End If
        End If
    Next
    If Not LignesSel Is Nothing Then LignesSel.Copy Feuil2.[A2]
    Feuil2.Select
    [A1].Select
End Sub

Il fonctionne parfaitement et j'en remercie encore l'auteur

Ce code copie les lignes entièrement et j'aurais besoin qu'il de me copie qu'une partie des lignes, par exemple toutes les lignes col A à D

Et ça, je ne sais pas faire et malgré mes recherches et essais, j'ai pas trouvé.

Auriez-vous la solution ? LOL ça m'arrangerait bien

Je joins le fichier test.
Un grand merci pour tout ce que vous faites.
Bonne journée à toutes et à tous,
Amicalement,
Arthour973,
 

Pièces jointes

  • test_bon.xls
    55.5 KB · Affichages: 23
Trier par date Trier par votes

job75

XLDnaute Barbatruc
Bonjour Lionel, heureux de te retrouver,

Il suffit de limiter les lignes avec Resize :
Code: 
           If Not LignesSel Is Nothing Then
                Set LignesSel = Union(LignesSel, cel.Resize(, 4))
            Else
                Set LignesSel = cel.Resize(, 4)
            End If
A+
 
Vote positif 0 Vote négatif

zebanx

XLDnaute Accro
Bonjour @arthour973, job75, le forum
Un autre code
@+

VB: 
  Sub Copie_F2()
  Dim L As Long
  Dim LignesSel As Range

    Set F1 = Sheets("Feuil1")
    Set F2 = Sheets("Feuil2")
    derlF2 = F2.Cells(Rows.Count, 1).End(3).Row

    For Each cel In Feuil1.Range("A2:A" & [A2].End(xlDown).Row)
        If cel.Value = "juju" Or cel.Value = "lola" Then
        Range(F1.Cells(cel.Row, 1), F1.Cells(cel.Row, 4)).Copy F2.Range("A" & derlF2 + 1)
        derlF2 = F2.Cells(Rows.Count, 1).End(3).Row
        End if
    Next

    F2.Select
    [A1].Select
End Sub
 

Pièces jointes

  • test_colAD.xls
    58 KB · Affichages: 17
Vote positif 0 Vote négatif

job75

XLDnaute Barbatruc
Re, salut zebanx,

La copie des lignes une par une de zebanx prend beaucoup trop de temps s'il y a beaucoup de lignes à copier.

La méthode Union du post #1 est plus rapide sauf s'il y a beaucoup (plusieurs milliers) de zones disjointes à unir.

Il n'y a pas de problème avec le filtre automatique :
Code: 
Sub Copie_filtre()
Dim F As Worksheet
Set F = Feuil2 'CodeName de la feuille de destination
F.Cells.Delete 'RAZ
With Feuil1.UsedRange.Resize(, 4)
    .AutoFilter 1, "juju", xlOr, "lola" 'filtre automatique
    .Copy Feuil2.[A1]
    .Parent.AutoFilterMode = False
End With
F.Columns.AutoFit 'ajustement largeurs
F.Visible = xlSheetVisible 'si la feuille est masquée
Application.Goto F.[A1], True 'cadrage
End Sub
Et si l'on veut copier uniquement les valeurs la méthode par tableau VBA est la plus rapide :
Code: 
Sub Copie_tableau()
Dim F As Worksheet, tablo, i&, n&, j%
Set F = Feuil2 'CodeName de la feuille de destination
F.Rows("2:" & F.Rows.Count).Delete 'RAZ
tablo = Feuil1.UsedRange.Resize(, 4) 'matrice, plus rapide
For i = 2 To UBound(tablo)
    If tablo(i, 1) = "juju" Or tablo(i, 1) = "lola" Then
        n = n + 1
        For j = 1 To 4: tablo(n, j) = tablo(i, j): Next
    End If
Next
If n Then F.[A2].Resize(n, 4) = tablo
F.Columns.AutoFit 'ajustement largeurs
F.Visible = xlSheetVisible 'si la feuille est masquée
Application.Goto F.[A1], True 'cadrage
End Sub
A+
 
Vote positif 0 Vote négatif

zebanx

XLDnaute Accro
Re-

Bon eh bien puisqu'on y est, test sur 30.000 lignes avec un code de JOB75 himself (the "master" of XLD) et sur 30.000 lignes on tourne sur les codes de ce post + ceux du 8 à moins de 0.1 s sauf sur les codes initiaux, comme indiqué par JOB75.
(Tous les codes sont mis dans ce fichier si tu veux vérifier @job75).

Tu avais envoyé ce code très agréable (et très légèrement modifié pour ce cas) pour une course de chevaux de ce cher Guido... qui se fait rare lui aussi (surement qu'il a touché le quinté plus dans l'ordre)

@+

VB: 
Sub sh01_code_sheet_2()
[COLOR=#b30000][COLOR=#b30000]'code de JOB75[/COLOR][/COLOR]
Dim t0

t0 = Timer
Application.ScreenUpdating = False
Application.EnableEvents = False
On Error Resume Next 'sécurité
Sheets(2).Range("A1:E" & Rows.Count).Delete xlUp 'RAZ
[g2] = "=OR(A2=""juju"", A2=""lola"")"
Range("A1:D" & Rows.Count).AdvancedFilter xlFilterCopy, Sheets(1).[G1:G2], Sheets(2).[A1:D1] '[A1:D1] 'filtre avancé
Sheets(1).[g2] = ""
Application.EnableEvents = True
MsgBox Format(Timer - t0, "0.000\sec.")
End Sub
 

Pièces jointes

  • test_colAD.zip
    711.2 KB · Affichages: 24
Vote positif 0 Vote négatif

Usine à gaz

XLDnaute Barbatruc
Supporter XLD
Bonjour à toutes et à tous,

Encore merci à Job75 et à Zébanx pour leur aide si précieuse.
Les codes fonctionnent super bien.
Je vais retenir le code de Job75 qui est super rapide :
Code: 
Sub Copie_tableau_job75_origine()
Dim F As Worksheet, tablo, i&, n&, j%, t0
t0 = Timer
Set F = Feuil2 'CodeName de la feuille de destination
F.Rows("2:" & F.Rows.Count).Delete 'RAZ
tablo = Feuil1.UsedRange.Resize(, 4) 'matrice, plus rapide
For i = 2 To UBound(tablo)
    If tablo(i, 2) > 148 Then 'tablo(i, 2)vérifie sur col B
        n = n + 1
        For j = 1 To 4: tablo(n, j) = tablo(i, j): Next
    End If
Next
If n Then F.[A2].Resize(n, 4) = tablo
'F.Columns.AutoFit 'ajustement largeurs
F.Visible = xlSheetVisible 'si la feuille est masquée
Application.Goto F.[A1], True 'cadrage
MsgBox Format(Timer - t0, "0.000_sec")
End Sub

Mais voilà, c'est en avançant qu'on s'aperçois que c'est plus compliqué LOL

Il m'est apparu que j'aurai besoin de copier les cellules de la Feuill1 comme présenté dans la Feuille "ma demande".
C'est à dire à partir de la colonne B

J'ai beau triffouiller le code mais je n'y arrive pas.
Auriez-vous la solution ?
Je joins le fichier test.

Encore une fois un grand merci pour votre gentillesse.
Amicalement,
Lionel,
 

Pièces jointes

  • boucle_Job75.xls
    3 MB · Affichages: 13
Vote positif 0 Vote négatif

zebanx

XLDnaute Accro
Bonjour @arthour973, le forum

En devançant peut-être un peu JOB75 sur son code et en espérant avoir compris.

@+
zebanx

VB: 
Sub Copie_tableau_job75_2()
Dim F As Worksheet, tablo, i&, n&, j%, t0

t0 = Timer
Set F = Feuil4
tablo = Feuil1.Range("B2:D" & Feuil1.Cells(Rows.Count, 2).End(3).Row)

'--- remplir tablo si valeur en colonne B > 148
For i = 2 To UBound(tablo, 1)
    If tablo(i, 1) > 148 Then
    n = n + 1
    For j = 1 To 3: tablo(n, j) = tablo(i, j): Next
    End If
Next
'--- restitution
If n Then F.[a2].Resize(n, 3) = tablo

F.Visible = xlSheetVisible
Application.Goto F.[A1], True
MsgBox Format(Timer - t0, "0.000_sec")
End Sub
 

Pièces jointes

  • boucle_Job75_2.xls
    3 MB · Affichages: 13
Vote positif 0 Vote négatif

zebanx

XLDnaute Accro
Et peut-être pour plus de clarté en partant de la colonne "A" pour la définition de tablo.

VB: 
Sub Copie_tableau_job75_colB_avecA()
Dim F As Worksheet, tablo, i&, n&, j%, t0

t0 = Timer
Set F = Feuil4
tablo = Feuil1.Range("A2:D" & Feuil1.Cells(Rows.Count, 2).End(3).Row)
ReDim tb(1 To UBound(tablo, 1), 1 To 3)

'--- remplir tablo si valeur en colonne B > 148
For i = 2 To UBound(tablo, 1)
    If tablo(i, 2) > 148 Then
    n = n + 1
    For j = 2 To 4
    tb(n, j - 1) = tablo(i, j)
    Next
End If
Next
'--- restitution
If n Then F.[a2].Resize(n, 3) = tb

F.Visible = xlSheetVisible
Application.Goto F.[A1], True
MsgBox Format(Timer - t0, "0.000_sec")
End Sub
 
Vote positif 0 Vote négatif
Identifiez-vous ou inscrivez-vous pour participer.

Discussions similaires

D
  • Question
Microsoft 365 Application.WorksheetFunction.VLookup ne fonctionne pas au delà de 8500 lignes
Réponses
4
Affichages
312
DimiJuju
D
U
  • Question
Autres [RESOLU] Déclaration de variable
Réponses
5
Affichages
212
un internaute
U
  • Question
XL 2013 Réduire un code
Réponses
0
Affichages
254
chaelie2015
S
  • Question
XL 2016 Macro pour convertir .PDF en .XLSX
3 4 5
Réponses
62
Affichages
2 K
Staple1600
S
  • Question
Microsoft 365 Clavier virtuel: SelectionChange, empêche la répétition
Réponses
3
Affichages
155
Simon 1234
S
D
  • Question
XL 2010 Identification d'une cellule cliquée
Réponses
6
Affichages
354
dadu35
D
  • Résolu(e)
XL 2013 (RESOLU) Code afficher/Masquer problème
Réponses
10
Affichages
239
chaelie2015
Y
  • Résolu(e)
XL 2013 Macro si changement dans case à cocher
Réponses
6
Affichages
158
Yvan1
Y
P
  • Résolu(e)
Microsoft 365 Private Sub Worksheet_Change(ByVal Target As Range)
Réponses
8
Affichages
337
pat66
P
  • Résolu(e)
XL 2016 If Not xRgSel Is Nothing Then --> Ne marche pas
Réponses
10
Affichages
170
R3n0W
Menu
Connexion
S'inscrire
Les cookies sont requis pour utiliser ce site. Vous devez les accepter pour continuer à utiliser le site. En savoir plus…