Vérifier valeur dans 2 colonnes pour sélection c/c
Résolu
WhiteCthulhu
-
WhiteCthulhu -
WhiteCthulhu -
Bonjour à tous,
Je cherche à rentrer un code permettant de ne copier/coller que les lignes d'un tableau dont les valeurs en colonnes 1 et/ou 2 ne sont pas vide.
Voici le code, je sais qu'il n'est pas propre ni efficace étant donné que c'est un mix entre de la macro auto, du code récupéré à droite à gauche et une dose d'initiative personnelle (inutile de préciser que je suis une buse en VBA!)
Dim Lig As Long
Dim Col As String
Dim NbrLig As Long
Dim NumLig As Long
Sheets("TEMPPASTE").Activate ' feuille de destination
Col = "Y" 'colonne de la donnée non vide à tester
Col2 = "AA" 'colonne de la donnée non vide à tester
NumLig = 1 'espace volontaire en haut de feuille
With Sheets("Feuil1") ' feuille source
NbrLig = .Cells(65536, Col).End(xlUp).Row
NbrLig = .Cells(65536, Col2).End(xlUp).Row
For Lig = 15 To NbrLig
If .Cells(Lig, Col).Value <> "" Or .Cells(Lig, Col2).Value <> "" Then
.Cells(Lig, Col).EntireRow.Copy
NumLig = NumLig + 1
Cells(NumLig, 1).Select
Cells(NumLig, 2).Select
ActiveSheet.Paste
End if
J'attends vos réactions horrifiées et peut être une réponse pouvant m'aider ;)
Merci
Je cherche à rentrer un code permettant de ne copier/coller que les lignes d'un tableau dont les valeurs en colonnes 1 et/ou 2 ne sont pas vide.
Voici le code, je sais qu'il n'est pas propre ni efficace étant donné que c'est un mix entre de la macro auto, du code récupéré à droite à gauche et une dose d'initiative personnelle (inutile de préciser que je suis une buse en VBA!)
Dim Lig As Long
Dim Col As String
Dim NbrLig As Long
Dim NumLig As Long
Sheets("TEMPPASTE").Activate ' feuille de destination
Col = "Y" 'colonne de la donnée non vide à tester
Col2 = "AA" 'colonne de la donnée non vide à tester
NumLig = 1 'espace volontaire en haut de feuille
With Sheets("Feuil1") ' feuille source
NbrLig = .Cells(65536, Col).End(xlUp).Row
NbrLig = .Cells(65536, Col2).End(xlUp).Row
For Lig = 15 To NbrLig
If .Cells(Lig, Col).Value <> "" Or .Cells(Lig, Col2).Value <> "" Then
.Cells(Lig, Col).EntireRow.Copy
NumLig = NumLig + 1
Cells(NumLig, 1).Select
Cells(NumLig, 2).Select
ActiveSheet.Paste
End if
J'attends vos réactions horrifiées et peut être une réponse pouvant m'aider ;)
Merci
2 réponses
-
bonjour,
essayez :
sub copiercoller
Dim Lig As Long
Dim Col As String
Dim NbrLig As Long
Dim NumLig As Long
Sheets("TEMPPASTE").Activate ' feuille de destination
destination=activesheet.name
Sheets("Feuil1").select
source = activesheet.name
Col = "Y" 'colonne de la donnée non vide à tester
Col2 = "AA" 'colonne de la donnée non vide à tester
NumLig = 2 'espace volontaire en haut de feuille
lig=15
do while cells(lig,col) <> "" or cells(lig,col2)<>""
If sheets(source).Cells(Lig, Col).Value <> "" Or sheets(source).Cells(Lig, Col2).Value <> "" Then
sheets(source).Cells(Lig, Col).EntireRow.Copy sheets(destination).Cells(NumLig, 1)
NumLig = NumLig + 1
End if
lig=lig+1
loop
end sub-
-
j'ai juste rajouter un do while :
Lig = 15 ==> ca c'est une variable
do while cells(lig,col) <> "" or cells(lig,col2)<>""
==> tant que la cellule de la ligne lig et colonne col <> "" (contient une donnée) ou que la cellule de la ligne lig et colonne col2 <>"" (contient une donnée)
on exécute le code
lig=lig+1 ==> passage à la ligne suivante
loop ==> ferme la boucle de do while -
Ah zut ! Si je n'ai pas de valeur sur ma première ligne (peut importe quelles colonnes Y ou AA) il s'arrête tout de suite et si j'ai des "trous" c-à-d que je vais avoir une valeur en Y ou AA sur la première ligne et une autre ligne par ex la 34 il ne la prends pas en compte et s'arrête juste après la première ligne car il ne trouve pas de valeur sur la suivante. D'après votre post du dessus surement le do while qui s'arrête dès qu'il rencontre une valeur "" alors que j'aurais besoin que le code continu de s'exécuter sur l'ensemble de la Feuil1.
Le code ne marche que si j'ai une valeur sur ma première ligne et que le reste des valeurs se suivent de lignes en lignes sans zone vide. -
Bon au cas où ça peut aider quelqu'un, j'ai peut être résolu mon problème avec un nouveau code :
Sub CC2()
Dim r As Long, endRow As Long, pasteRowIndex As Long
Set WS = Worksheets("Feuil1")
With WS
Set LastCell = .Cells(.Rows.Count, "y").End(xlUp)
LastCellRowNumber = LastCell.Row
End With
pasteRowIndex = 1
For r = 15 To LastCellRowNumber
If (Cells(r, Columns("Y").Column).Value) <> "" Or (Cells(r, Columns("AA").Column).Value) <> "" Then '
Rows(r).Select
Selection.Copy
Sheets("TEMPPASTE").Select
Rows(pasteRowIndex).Select
ActiveSheet.Paste
pasteRowIndex = pasteRowIndex + 1
Sheets("feuil1").Select
End If
Next r
Sheets("TEMPPASTE").Select
Columns("A:A").Select
Selection.Delete Shift:=xlToLeft
Cells.Select
Selection.RowHeight = 13.5
End Sub -
-
-
Bonjour,
essaie ca :
sub copiercoller
Dim Lig As Long
Dim Col As String
Dim NbrLig As Long
Dim NumLig As Long
Sheets("TEMPPASTE").Activate ' feuille de destination
destination=activesheet.name
Sheets("Feuil1").select
source = activesheet.name
Col = "Y" 'colonne de la donnée non vide à tester
Col2 = "AA" 'colonne de la donnée non vide à tester
NumLig = 2 'espace volontaire en haut de feuille
NbrLig = sheets(source).Cells(65536, Col).End(xlUp).Row
NbrLig = sheets(source).Cells(65536, Col2).End(xlUp).Row
For Lig = 15 To NbrLig
If sheets(source).Cells(Lig, Col).Value <> "" Or sheets(source).Cells(Lig, Col2).Value <> "" Then
sheets(source).Cells(Lig, Col).EntireRow.Copy sheets(destination).Cells(NumLig, 1)
NumLig = NumLig + 1
End if
next
end sub
