Macro couper coller des lignes bien spécial
Bonjour,
il y' a il un moyen de faire un Macro qui fait couper des lignes qui comportent un mot ( MOT ) dans une cellule AX (X=un nombre) dans une feuille (FEUILLE1) , et les coller dans une feuille (FEUILLE2) à partir de la ligne 40 .... jusqu’à N lignes ,ça pédant du nombre de lignes trouvées !
Merci pour votre aide
ci joint le fichier exemple : dans ce cas :
je veux couper la ligne 13 et 16 ou on trouve le mot 'mot' de la feuille 1
et les coller dasn la feuille 2 à partir de la ligne 14 .
bonjour,
à tester
Sub try()
Application.ScreenUpdating = False
Dim myRange As Range, derLig As Range, myCell As Range, myAnchor As Range
With Sheets("Feuil2")
If Not IsEmpty(.Range("A14")) Then
.Range("A14").CurrentRegion.Offset(1).Clear
End If
End With
With Sheets("Feuil1")
Set derLig = .Range("A" & Rows.Count).End(xlUp)
Set myRange = .Range(.Range("A9"), derLig)
Set myCell = myRange.Find(UCase("mot"), , , xlPart)
Set myAnchor = myCell
If Not myCell Is Nothing Then
Do
Set myCell = myRange.Find(UCase("mot"), myCell, , xlPart)
.Rows(myCell.Row).Cut Sheets("Feuil2").Range("A" & Rows.Count).End(xlUp).Offset(1)
Loop Until myCell.Address = myAnchor.Address
End If
End With
Application.CutCopyMode = False
End SubExcellent travail , merci bcp
ça fonctionne avec une seul ligne !! je viens d'ajouter d'autre ligne . mais toujours il prends une seul !!
Sub try()
Application.ScreenUpdating = False
Dim myRange As Range, derLig As Range, myCell As Range, myAnchor As Range
With Sheets("Nouveau PROXY")
If Not IsEmpty(.Range("A41")) Then
.Range("A41").CurrentRegion.Offset(1).Clear
End If
End With
With Sheets("Nouveau ACL")
Set derLig = .Range("A" & Rows.Count).End(xlUp)
Set myRange = .Range(.Range("A40"), derLig)
Set myCell = myRange.Find(UCase("http"), , , xlPart)
Set myAnchor = myCell
If Not myCell Is Nothing Then
Do
Set myCell = myRange.Find(UCase("http"), myCell, , xlPart)
.Rows(myCell.Row).Cut Sheets("Nouveau PROXY").Range("A" & Rows.Count).End(xlUp).Offset(1)
Loop Until myCell.Address = myAnchor.Address
End If
End With
Application.CutCopyMode = False
End SubTu as utilisé le terme "couper" dans ton message, or "Couper" est un terme bien précis sur Excel : pour t'en convaincre, va sur n'importe quelle cellule d'Excel et fais un clic droit.
La macro a donc coupé l'information requise !
rajoute cette boucle à la fin de la macro, juste avant End Sub
For Each a In myRange
If IsEmpty(a) Then Rows(a.Row).Delete
Next acoolmomodu31 a écrit :ça fonctionne avec une seul ligne !! je viens d'ajouter d'autre ligne . mais toujours il prends une seul !!
ben, j'en sais rien, je peux pas te dire sans voir ton fichier...
Game Over a écrit :Tu as utilisé le terme "couper" dans ton message, or "Couper" est un terme bien précis sur Excel : pour t'en convaincre, va sur n'importe quelle cellule d'Excel et fais un clic droit.
La macro a donc coupé l'information requise !
rajoute cette boucle à la fin de la macro, juste avant End Sub
For Each a In myRange If IsEmpty(a) Then Rows(a.Row).Delete Next acoolmomodu31 a écrit :ça fonctionne avec une seul ligne !! je viens d'ajouter d'autre ligne . mais toujours il prends une seul !!
ben, j'en sais rien, je peux pas te dire sans voir ton fichier...
oki merci bien mon ami c'est gentil
coolmomodu31 a écrit :Game Over a écrit :Tu as utilisé le terme "couper" dans ton message, or "Couper" est un terme bien précis sur Excel : pour t'en convaincre, va sur n'importe quelle cellule d'Excel et fais un clic droit.
La macro a donc coupé l'information requise !
rajoute cette boucle à la fin de la macro, juste avant End Sub
For Each a In myRange If IsEmpty(a) Then Rows(a.Row).Delete Next acoolmomodu31 a écrit :ça fonctionne avec une seul ligne !! je viens d'ajouter d'autre ligne . mais toujours il prends une seul !!
ben, j'en sais rien, je peux pas te dire sans voir ton fichier...
oki merci bien mon ami c'est gentil
voici ci-joint le fichier , j'ai pas compris d'ou viens l'erreur !! exécute le macro en premier lieu ! et répète le une 2éme fois !!
j'ai pu arrivé à çaet ça fonctionne bien
Sub tesst()
dernligne = Sheets("Nouveau ACL").Range("A" & Rows.Count).End(xlUp).Row
k = 41
For i = 1 To dernligne
If Sheets("Nouveau ACL").Cells(i, 1) = "http" Then
Sheets("Nouveau ACL").Cells(i, 1).EntireRow.Copy Sheets("Nouveau PROXY").Cells(k, 1)
Sheets("Nouveau ACL").Cells(i, 1).EntireRow.Delete
k = k + 1
End If
Next i
End SubDans ton cas de figure (suppression de ligne plutôt que l'utilisation de la fonction "Couper"), ta macro devient plus adaptée à la solution que j'avais proposée initialement.
je poste quand même une version corrigée qui traite toutes les lignes et non juste une seule, juste pour info.
Sub try()
Application.ScreenUpdating = False
Dim myRange As Range, derLig As Range, myCell As Range, myAnchor As Range
With Sheets("Nouveau PROXY")
If Not IsEmpty(.Range("A41")) Then
.Range("A41").CurrentRegion.Offset(1).Clear
End If
End With
With Sheets("Nouveau ACL")
Set derLig = .Range("A" & Rows.Count).End(xlUp)
Set myRange = .Range(.Range("A40"), derLig)
myRange.Select
Set myCell = myRange.Find(UCase("http"), , , xlPart)
If Not myCell Is Nothing Then
Set myAnchor = myCell
Do
.Rows(myCell.Row).Cut Sheets("Nouveau PROXY").Range("A" & Rows.Count).End(xlUp).Offset(1)
Set myCell = myRange.Find(UCase("http"), myCell, , xlPart)
Loop Until myCell.Address = myAnchor.Address
End If
End With
Application.CutCopyMode = False
End SubGame Over a écrit :Dans ton cas de figure (suppression de ligne plutôt que l'utilisation de la fonction "Couper"), ta macro devient plus adaptée à la solution que j'avais proposée initialement.
je poste quand même une version corrigée qui traite toutes les lignes et non juste une seule, juste pour info.
Sub try() Application.ScreenUpdating = False Dim myRange As Range, derLig As Range, myCell As Range, myAnchor As Range With Sheets("Nouveau PROXY") If Not IsEmpty(.Range("A41")) Then .Range("A41").CurrentRegion.Offset(1).Clear End If End With With Sheets("Nouveau ACL") Set derLig = .Range("A" & Rows.Count).End(xlUp) Set myRange = .Range(.Range("A40"), derLig) myRange.Select Set myCell = myRange.Find(UCase("http"), , , xlPart) If Not myCell Is Nothing Then Set myAnchor = myCell Do .Rows(myCell.Row).Cut Sheets("Nouveau PROXY").Range("A" & Rows.Count).End(xlUp).Offset(1) Set myCell = myRange.Find(UCase("http"), myCell, , xlPart) Loop Until myCell.Address = myAnchor.Address End If End With Application.CutCopyMode = False End Sub
ah oki merci le code ci dessous donne une erreur ici dasn la compilation " Loop Until myCell.Address = myAnchor.Address " !!!
coolmomodu31 a écrit :ah oki merci le code ci dessous donne une erreur ici dasn la compilation " Loop Until myCell.Address = myAnchor.Address " !!!
J'ai fait des tests, finalement, il semble que les fonctions Find et Cut ne cohabitent pas bien ensemble.
Quand on coupe l'information, on supprime dans le même temps de la feuille une référence dont a besoin Excel pour faire sa boucle de recherche pour toutes les cellules contenant http.
Donc ma solution n'est clairement pas convenable dans ton cas de figure.
ah d'accord je vois , merci mon ami meme la prémiére il faut ça fonctionne pas bien voici le dérnier code à jour qui fonctionne bien :
Sub toto()
dernligne = Sheets(1).Range("A" & Rows.Count).End(xlUp).Row
k = 41
For i = 1 To dernligne
If Sheets(1).Cells(i, 1) = "http" Then
Sheets(1).Cells(i, 1).EntireRow.Copy Sheets(2).Cells(k, 1)
k = k + 1
End If
Next i
For i = dernligne To 1 Step -1
If Sheets(1).Cells(i, 1) = "http" Then
Sheets(1).Cells(i, 1).EntireRow.Delete
End If
Next i
End SubTu pourrais simplifier ton code comme ça, non ?! et ça va même accélérer sa vitesse d'exécution.
dernligne = Sheets(1).Range("A" & Rows.Count).End(xlUp).Row
k = 41
For i = 1 To dernligne
If Sheets(1).Cells(i, 1) = "http" Then
Sheets(1).Cells(i, 1).EntireRow.Copy Sheets(2).Cells(k, 1)
Sheets(1).Cells(i, 1).EntireRow.Delete
k = k + 1
End If
Next ivoici une autre solution, plus compliquée mais aussi plus rapide à l'exécution, donc à mettre en place seulement si tu as vraiment un grand nombre de lignes à traiter, sinon, ton code convient parfaitement.
Option Base 1
Sub try()
Application.ScreenUpdating = False
Dim myRange As Range
Dim aa As Variant, Tablo1() As Variant, Tablo2() As Variant
Dim a As Long, b As Long
With Sheets("Nouveau PROXY")
If Not IsEmpty(.Range("A41")) Then
.Range("A38").CurrentRegion.Offset(3).Resize(.Range("A38").CurrentRegion.Rows.Count - 3, .Range("A38").CurrentRegion.Columns.Count).Clear
End If
End With
With Sheets("Nouveau ACL")
Set myRange = .Range("A38").CurrentRegion.Offset(3).Resize(.Range("A38").CurrentRegion.Rows.Count - 3, .Range("A38").CurrentRegion.Columns.Count)
End With
aa = myRange
zz = UBound(aa)
For i = LBound(aa) To UBound(aa)
If UCase(aa(i, 1)) = UCase("http") Then
a = a + 1
ReDim Preserve Tablo1(a)
Tablo1(a) = Application.Index(aa, i)
Else
b = b + 1
ReDim Preserve Tablo2(b)
Tablo2(b) = Application.Index(aa, i)
End If
Next i
myRange.Clear
If a > 0 Then routine "Nouveau PROXY", Tablo1, aa
If b > 0 Then routine "Nouveau ACL", Tablo2, aa
Application.CutCopyMode = False
Erase aa: Erase Tablo1: Erase Tablo2
End Sub
Sub routine(ee, ff, aa)
Dim myAnchor As Range
Set myAnchor = Sheets(ee).Range("A41").Resize(UBound(ff), UBound(aa, 2))
myAnchor = Application.Transpose(Application.Transpose(ff))
With myAnchor
.Borders.LineStyle = xlContinuous
.HorizontalAlignment = xlCenter
End With
End SubGame Over a écrit :Tu pourrais simplifier ton code comme ça, non ?! et ça va même accélérer sa vitesse d'exécution.
dernligne = Sheets(1).Range("A" & Rows.Count).End(xlUp).Row k = 41 For i = 1 To dernligne If Sheets(1).Cells(i, 1) = "http" Then Sheets(1).Cells(i, 1).EntireRow.Copy Sheets(2).Cells(k, 1) Sheets(1).Cells(i, 1).EntireRow.Delete k = k + 1 End If Next ivoici une autre solution, plus compliquée mais aussi plus rapide à l'exécution, donc à mettre en place seulement si tu as vraiment un grand nombre de lignes à traiter, sinon, ton code convient parfaitement.
Option Base 1 Sub try() Application.ScreenUpdating = False Dim myRange As Range Dim aa As Variant, Tablo1() As Variant, Tablo2() As Variant Dim a As Long, b As Long With Sheets("Nouveau PROXY") If Not IsEmpty(.Range("A41")) Then .Range("A38").CurrentRegion.Offset(3).Resize(.Range("A38").CurrentRegion.Rows.Count - 3, .Range("A38").CurrentRegion.Columns.Count).Clear End If End With With Sheets("Nouveau ACL") Set myRange = .Range("A38").CurrentRegion.Offset(3).Resize(.Range("A38").CurrentRegion.Rows.Count - 3, .Range("A38").CurrentRegion.Columns.Count) End With aa = myRange zz = UBound(aa) For i = LBound(aa) To UBound(aa) If UCase(aa(i, 1)) = UCase("http") Then a = a + 1 ReDim Preserve Tablo1(UBound(aa, 2), a) For Z = 1 To UBound(aa, 2) Tablo1(Z, a) = aa(i, Z) Next Z Else b = b + 1 ReDim Preserve Tablo2(UBound(aa, 2), b) For Z = 1 To UBound(aa, 2) Tablo2(Z, b) = aa(i, Z) Next Z End If Next i myRange.Clear If a > 0 Then routine "Nouveau PROXY", Tablo1, aa If b > 0 Then routine "Nouveau ACL", Tablo2, aa Application.CutCopyMode = False Erase aa: Erase Tablo1: Erase Tablo2 End Sub Sub routine(ee, ff, aa) Dim myAnchor As Range Set myAnchor = Sheets(ee).Range("A41").Resize(UBound(ff, 2), UBound(aa, 2)) myAnchor = Application.Transpose(ff) With myAnchor .Borders.LineStyle = xlContinuous .HorizontalAlignment = xlCenter End With End Sub
avec une seule boucle ça fonctionne (ça fait coupper coller les lignes ) mais les lignes 'http' restent dans la première feuille alors il faut les supprimer et faire monter les autres dans les ligne vide ...
les 2 boucles font un travail complet