Rangement de cellules avec macro

Bonjour à toutes et à tous

J'ai enregistré une macro pour déplacer des cellules via une autre feuille selon condition. J'aimerais un code mieux adapté et surtout moins lourd. je joins le fichier + voici le code.

Merci de vôtre aide.

Sub Macro()

         Sheets("Temp").Select
    Range("A32").Select
    Selection.End(xlDown).Select
    Cells.Find(What:="CHIFFRE SUPPRIMER", After:=ActiveCell, LookIn:=xlFormulas _
        , LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False, SearchFormat:=False).Activate
    Range("A18:D50").Select
    Selection.Delete Shift:=xlUp
    Range("A18").Select
     Range("B2").Select
    Selection.Cut Destination:=Range("D1")
    Range("B4").Select
    Selection.Cut Destination:=Range("E1")
    Range("B5").Select
    Selection.Cut Destination:=Range("F1")
    Range("B6").Select
    Selection.Cut Destination:=Range("G1")
    Range("B8").Select
    Selection.Cut Destination:=Range("H1")
    Range("B10").Select
    Selection.Cut Destination:=Range("I1")
    Range("B11").Select
    Selection.Cut Destination:=Range("J1")
    Range("B12").Select
    Selection.Cut Destination:=Range("K1")
    Range("B14").Select
    Selection.Cut Destination:=Range("L1")
    Range("B16").Select
    Selection.Cut Destination:=Range("B15")
    Range("B15").Select
    Selection.Cut Destination:=Range("M1")
    Range("D1:P1").Select
    Selection.Copy
    Sheets("Data").Select
    Range("F2:F18").Select
    ActiveSheet.Paste
    Range("F2").Select

End Sub

Salut Muratime,

voici ta macro, à tester en situation réelle.

Vu le contexte très particulier, il faudrait plus d'explications quant à une utilisation régulière...

A+

Je crois que ça fonctionne parfaitement bien je te remercie 1000 fois

Un petit détail, me suis aperçu que je voulais supprimer toutes les lignes comprenant le mot "Transformé" avant qu'il importe dans la feuille Data, j'ai donc essayé ce code mais il ne fonctionne que si je suis sur la feuille Temp en question !!!

Sub Transforme()
Dim I As Integer
With Sheets("Temp")
For I = [A65000].End(xlUp).Row To 1 Step -1
If Not Cells(I, 1).Find("Transformé") Is Nothing Then Rows(I).Delete
Next I
End With
End Sub

J'ai essayé de l'intégré dans ton code aussi directement vu que ça se passe sur la feuille Temp mais pareil j'arrive pas a le faire fonctionner.

Aurais tu une solution ?

Merci

Salut Muratime,

'Transformé' ?! Pas vu ça!

Pour continuer sur ton fichier, manifestement à surprises, rassemble toutes tes demandes et fournis-nous un fichier en situation réelle que nous puissions comprendre et ne travailler qu'une fois dessus!

A+

Non il n'y avait pas le mot transformé mais supposons qu'il y soit. J'ai essayé ça fonctionne avec un select mais bon, souvent entendu qu'il fallait éviter les select et si je masque ma feuille ça convient pas le select

Sub Transforme()
 Dim I As Integer

Sheets("Temp").Select

For I = [A65000].End(xlUp).Row To 1 Step -1
If Not Cells(I, 1).Find("Transformé") Is Nothing Then Rows(I).Delete
Next I
End Sub

Salut Muratime,

Tu n'étais pas loin!

Quand tu utilises 'With...', il faut impérativement mettre un point devant chaque référence à la feuille concernée.

Ainsi : .Cells, .Rows

Sub Transforme()
'
Dim I As Integer
'
With Sheets("Temp")
    For I = .Cells(Rows.Count, 1).End(xlUp).Row To 1 Step -1
        If Not .Cells(I, 1).Find("Transformé") Is Nothing Then .Rows(I).Delete shift:=xlUp
    Next I
End With
'
End Sub

Et ça fonctionnera...

a+

Ah oui effectivement ça fonctionne mieux j'ai mis dans ton code pour éviter de rajouter un sub. j'ai fais comme ça dis moi si c'est correct ? En tous cas ça fonctionne

Sub Macro()
'
Dim tTabO, tLib(), tTabF()
Dim x, iRow, iIdx As Integer

Application.ScreenUpdating = False
'
With Worksheets("Temp")
For x = .Cells(Rows.Count, 1).End(xlUp).Row To 1 Step -1
        If Not .Cells(x, 1).Find("Transformé") Is Nothing Then .Rows(x).Delete shift:=xlUp
    Next x
    iRow = .Cells(Rows.Count, 1).End(xlUp).Row
    tTabO = .Range("A1:B" & iRow)
End With
'

For x = 1 To UBound(tTabO, 1)
    If tTabO(x, 1) = "CHIFFRE SUPPRIMER" Then Exit For
    If tTabO(x, 1) <> "" Then

        iIdx = iIdx + 1
        ReDim Preserve tLib(1, iIdx)
        ReDim Preserve tTabF(1, iIdx)
        tLib(0, iIdx - 1) = tTabO(x, 1)
        tTabF(0, iIdx - 1) = tTabO(x, 2)
    End If
Next
'
With Worksheets("Data")
    iRow = .Cells(Rows.Count, 1).End(xlUp).Row
    .Range("F1").Resize(1, iIdx) = tLib
    .Range("F1").Resize(1, iIdx).Interior.Color = RGB(255, 150, 200)
    For x = 2 To iRow
        .Range("F" & x).Resize(1, iIdx) = tTabF
    Next
End With
'
Application.ScreenUpdating = True
'
End Sub

Bonjour Muratime,

oui, c'est parfait! Il fallait effectivement placer ce bout de code AVANT le calcul de la hauteur de colonne iRow=...

A+

Bon bah OK ça roule