Modifier l'extraction de ligne entière extraction col spécifique [Résolu/Fermé]

Signaler
-
 bitbit -
Bonjour, La communauté



Ce code extrait toutes la ligne. Peut on l'améliorer ? Au lieu de .Cells(Lig, Col).EntireRow.Copy qui extrait toute la ligne, je voudrais plutôt copier Col [Ax: Hx]


Sub Macroextraction_2()
Dim Lig As Long
Dim Col As String
Dim NbrLig As Long
Dim NumLig As Long
Col = "J" ' colonne données non vides à tester'
NumLig = 1 'alors là ca doit etre le N° de la 1er ligne de données en comptant la ligne 1 = 0 .... ?
With Sheets("1") ' feuille source'
NbrLig = .Cells(1048576, Col).End(xlUp).Row
For Lig = 1 To NbrLig 'n° de la 1ere ligne de données'
If .Cells(Lig, Col).Value = 1 Then
.Cells(Lig, Col).EntireRow.Copy
NumLig = NumLig + 1
Sheets("2").Cells(NumLig, 1).Insert Shift:=xlDown
'ici pour insérer ou .Paste pour coller'
End If
Next
End With

End Sub

3 réponses

Messages postés
3334
Date d'inscription
samedi 20 juillet 2013
Statut
Membre
Dernière intervention
9 décembre 2016
528
Bonjour,

Sub Macroextraction_2()
Dim Lig As Long
Dim Col As String
Dim NbrLig As Long
Dim NumLig As Long
Col = "J" ' colonne données non vides à tester'
NumLig = 1 'alors là ca doit etre le N° de la 1er ligne de données en comptant la ligne 1 = 0 .... ?
With Sheets("1") ' feuille source'
NbrLig = .Cells(1048576, Col).End(xlUp).Row
For Lig = 1 To NbrLig 'n° de la 1ere ligne de données'
If .Cells(Lig, Col).Value = 1 Then
.Cells(Lig, 1).Resize(, 8).Copy
NumLig = NumLig + 1
Sheets("2").Cells(NumLig, 1).Insert Shift:=xlDown
'ici pour insérer ou .Paste pour coller'
End If
Next Lig
End With
End Sub

A+
Bravo Gyrus, vous avez résolu mon problème. Merci
A Gyrus
Est-il possible de désélectionner la zone copiée(sur la page source, la ligne copier reste active) ceci est une question facultative pas urgente. Une fois de + M6
Messages postés
3334
Date d'inscription
samedi 20 juillet 2013
Statut
Membre
Dernière intervention
9 décembre 2016
528
Bonjour,

Voici le code après adaptations :
Sub Macroextraction_2()
Dim Lig As Long
Dim Col As String
Dim NbrLig As Long
Dim NumLig As Long
Application.ScreenUpdating = False
Col = "J" ' colonne données non vides à tester'
NumLig = 1 'alors là ca doit etre le N° de la 1er ligne de données en comptant la ligne 1 = 0 .... ?
With Sheets("1") ' feuille source'
NbrLig = .Cells(1048576, Col).End(xlUp).Row
For Lig = 1 To NbrLig 'n° de la 1ere ligne de données'
If .Cells(Lig, Col).Value = 1 Then
.Cells(Lig, 1).Resize(, 8).Copy
NumLig = NumLig + 1
Sheets("2").Cells(NumLig, 1).Insert Shift:=xlDown
'ici pour insérer ou .Paste pour coller'
End If
Next Lig
Application.CutCopyMode = False
End With
Application.ScreenUpdating = True
End Sub


A+
Waouooooooo. C'est parfait. C'est confirmé, je sais à présent que rien n'est impossible en informatque. M6 A+