XL 2013 Ne pas copier les lignes complètes

[Usine à gaz]

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 🙂)

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,

 

[job75]

Bonjour Lionel, heureux de te retrouver,

Il suffit de limiter les lignes avec Resize :

           If Not LignesSel Is Nothing Then
                Set LignesSel = Union(LignesSel, cel.Resize(, 4))
            Else
                Set LignesSel = cel.Resize(, 4)
            End If

A+

 

[zebanx]

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

  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

 

[Usine à gaz]

Bonjour Job,
Heureux aussi 😉

Merci encore une fois pour m'avoir répondu (je ne les compte plus) LOL, je n'avais pas pensé à Resize

Je vais voir et je te dis.
Amicalement,
Lionel,

 

[Usine à gaz]

Bonjour Zebanx,

Un grand merci à toi aussi pour m'avoir répondu
Je vais tester et je reviens.
Amicalement,
Arthour973 🙂

 

[Usine à gaz]

Re Job,

Super ça marche nickel 😉
Je te remercie,
Amicalement,
Lionel,

 

[Usine à gaz]

Re Zebanx,

Super ça marche 😉
Un grand merci aussi,
Amicalement,
Arthour973

 

[job75]

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 :

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 :

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+

 

[Usine à gaz]

Vraiment merci à toi pour tant de précision.
et ... ça marche super bien 🙂
Amicalement,
Lionel,

 

[zebanx]

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🙄)

@+

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

 

[Usine à gaz]

à Job75,
à Zébanx,
Re-bonjour,
Super vraiment 🙂

 

[Usine à gaz]

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 :

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,

 

[zebanx]

Bonjour @arthour973, le forum

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

@+
zebanx

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

 

[Usine à gaz]

Merci Zébanx,

Je vais regarder et je te dis 🙂

 

[zebanx]

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

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