[XL-2007] Extraction de lignes vides [Résolu]

[apt]

Bonjour à tous,

J'aimerais extraire toutes les lignes contenant un vide (incompete) avec ce code :

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
Private Sub CommandButton1_Click()
 
    Dim Cel As Range
    Dim LastLg As Integer
 
    LastLg = Sheets("BD").[A65000].End(xlUp).Row
    MsgBox "LastLg = " & LastLg
    Sheets("Incomplets").Range([A3], Range("F" & [A65000].End(xlUp).Row)).ClearContents
 
    For Each Cel In Sheets("BD").Range("A2:F" & LastLg).Rows
        If Application.CountBlank(Cel) > 0 Then
            MsgBox "Cel adddresse = " & Cel.Address & vbCrLf & _
                   "Cel.row = " & Cel.Row & vbCrLf & _
                   "Range(A" & Cel.Row & ":K" & Cel.Row & ")"
            Sheets("BD").Range("A" & Cel.Row & ":K" & Cel.Row).Copy Sheets("Incomplets").Range("A3")
        End If
    Next Cel
 
End Sub

Mias j'ai une erreur dans cette ligne :

Code :

Sheets("Incomplets").Range([A3], Range("F" & [A65000].End(xlUp).Row)).ClearContents

Merci.

[gFZT82]

Bonjour,

Tu as tout intérêt à indiquer explicitement sur quelle feuille tu effectues tes opérations.

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
Private Sub CommandButton1_Click()
    Dim Cel As Range
    Dim LastLg As Long
    Dim Ws1 As Worksheet
    Dim Ws2 As Worksheet
 
    Set Ws1 = Worksheets("BD")
    Set Ws2 = Worksheets("Incomplets")
    LastLg = Ws1.[A65000].End(xlUp).Row
    MsgBox "LastLg = " & LastLg
    Ws2.Range(Ws2.Range("A3"), Ws2.Range("F" & Ws2.[A65000].End(xlUp).Row)).ClearContents
    For Each Cel In Ws1.Range("A2:F" & LastLg).Rows
        If Application.CountBlank(Cel) > 0 Then
            MsgBox "Cel adddresse = " & Cel.Address & vbCrLf & _
                   "Cel.row = " & Cel.Row & vbCrLf & _
                   "Range(A" & Cel.Row & ":K" & Cel.Row & ")"
            Ws1.Range("A" & Cel.Row & ":K" & Cel.Row).Copy Ws2.Range("A3")
        End If
    Next Cel
    Set Ws1 = Nothing
    Set Ws2 = Nothing
End Sub

Cordialement.

[apt]

Bonjour gF

J'ai un souci.

Le copiage des lignes ne se fait que sur la premiere ligne de la feuille "Incomplets".

Pourtant j'ai bien changé cette ligne :

Code :

Ws1.Range("A" & Cel.Row & ":K" & Cel.Row).Copy Ws2.Range("A3")

Par :

Code :

Ws1.Range("A" & Cel.Row & ":F" & Cel.Row).Copy Ws2.Range("A" & Ws2.[A65000].End(xlUp).Row)

[gFZT82]

Lorsque tu écris

Code :

Ws1.Range("A" & Cel.Row & ":F" & Cel.Row).Copy Ws2.Range("A3")

tu indiques la plage à copier et l’emplacement de la première cellule, en haut à gauche, où sera copiée cette plage.

Exemple avec Cel.Row=1

Code :

Ws1.Range("A1:F1”).Copy Ws2.Range("A3")

Je copie la plage A1:F1 de la feuille1 dans la feuille2, à partir de la cellule A3. Ma plage est donc copiée dans la feuille 2 en A3:F3.

Cordialement.

[apt]

Salut,

C'est pour cela que je calcul la dernière ligne dans Ws2, avant chaque extration.

Et même en décalant la dernière ligne d'une position en bas, j'aurais des lignes copiées en A2.

J'ai remplacé par cette ligne, mais toujours le même résultat :

Code :

Ws1.Range("A" & Cel.Row & ":F" & Cel.Row).Copy Ws2.Range("A" & Ws2.[A65000].End(xlUp).Offset(1, 0).Row)

Un truc m'échappe

[gFZT82]

Je pense qu'on n'arrive pas à se comprendre .

La copie s'effectue avec

Code :

Ws1.Range("A" & Cel.Row & ":F" & Cel.Row).Copy

Tu ne copie qu'une ligne, celle qui porte le numéro Cel.Row.

Pour le collage dans la feuille 2, il ne sert à rien d'écrire

Code :

Ws2.Range("A" & Ws2.[A65000].End(xlUp).Offset(1, 0).Row)

car tu ne vas pas coller autre chose que ce que tu as copié.

Si tu souhaites copier plusieurs lignes, c'est sur la première partie qu'il faut le déclarer
Exemple avec la copie de 5 lignes

Code :

Ws1.Range("A" & Cel.Row & ":F" & Cel.Row+5).Copy

Cordialement.

[apt]

Mon problème réside dans la destination de lignes trouvées dans la première feuille.

Pour mieux éclairer le problème, un exemple en PJ.

[gFZT82]

O.K c'est vu.
Il suffit d'incrémenter LastCopy après chaque copie (LastCopy = LastCopy + 1).

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
Private Sub CommandButton1_Click()
    Dim Cel As Range
    Dim LastLg As Long, LastCopy As Long
    Dim Ws1 As Worksheet
    Dim Ws2 As Worksheet
 
    Set Ws1 = Worksheets("BD")
    Set Ws2 = Worksheets("Incomplets")
    LastLg = Ws1.[A65000].End(xlUp).Row
    LastCopy = Ws2.[A65000].End(xlUp).Row
 
    MsgBox "LastLg in BD = " & LastLg & vbCrLf & _
           "LastCopy in Incomplets = " & LastCopy
 
    Ws2.Range(Ws2.Range("A4"), Ws2.Range("F" & LastCopy)).ClearContents
 
    For Each Cel In Ws1.Range("A2:F" & LastLg).Rows
        If Application.CountBlank(Cel) > 0 Then
            MsgBox "Cel adddresse = " & Cel.Address & vbCrLf & _
                   "Cel.row = " & Cel.Row & vbCrLf & _
                   "Range(A" & Cel.Row & ":K" & Cel.Row & ")" & vbCrLf & _
                   "Copy dans incomplets à la ligne A" & Ws2.[A65000].End(xlUp).Row + 1    ' Ws2.[A65000].End(xlUp).Offset(1, 0).Row
 
            Ws1.Range("A" & Cel.Row & ":F" & Cel.Row).Copy Ws2.Range("A" & LastCopy + 1)
            LastCopy = LastCopy + 1
            Ws2.Select
        End If
    Next Cel
    Set Ws1 = Nothing
    Set Ws2 = Nothing
End Sub

Cordialement.

Je te retourne le code après test et corrections.

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
Private Sub CommandButton1_Click()
    Dim Cel As Range
    Dim LastLg As Long, LastCopy As Long
    Dim Ws1 As Worksheet
    Dim Ws2 As Worksheet
 
    Set Ws1 = Worksheets("BD")
    Set Ws2 = Worksheets("Incomplets")
 
    DerLigWs1 = Ws1.Range("A" & Ws1.Rows.Count).End(xlUp).Row
    DerLigWs2 = Ws2.Range("A" & Ws2.Rows.Count).End(xlUp).Row
    LigneAjout = 4
    MsgBox "Dernière ligne renseignée dans BD = " & DerLigWs1 & vbCrLf & _
           "Dernière ligne renseignée dans Incomplets = " & DerLigWs2
 
    Ws2.Range(Ws2.Range("A4"), Ws2.Range("F" & DerLigWs2 + 1)).Delete Shift:=xlUp
 
    For Each Cel In Ws1.Range("A2:F" & DerLigWs1).Rows
        If Application.CountBlank(Cel) > 0 Then
            Ws1.Range("A" & Cel.Row & ":F" & Cel.Row).Copy Ws2.Range("A" & LigneAjout)
            LigneAjout = LigneAjout + 1
        End If
    Next Cel
    Ws2.Select
 
    Set Ws1 = Nothing
    Set Ws2 = Nothing
End Sub

Cordialement.

[apt]

Bonsoir gFZT82,

Un code simple et très clair

Merci infinement.

Salutations