XL 2016 Besoin d'astuce pour un VBA cut/move

[wishtolearn]

Hello à tous,

Grâce à l'aide des membres de ce forum mon fichier excel est quasi prêt. Afin de le parfaire, j'aurais besoin de vos lumières pour deux petites choses concernant le même code VBA

• que puis-je rajouter pour que, suite au cut des lignes entières, Excel "colle" en mode value only? Les lignes des feuilles de destination contenant des mise en forme conditionnelles avec des couleurs, le "collage brut" d'excel suite à l'usage de la macro rajoute bien les lignes mais fait sauter ces MFC
  
  

  Sub Others()Dim i As Variant
  Dim endrow As Integer
  Dim DAV As Worksheet, OTH As Worksheet
  
  Set DAV = ActiveWorkbook.Sheets("Demandes à valider")
  Set OTH = ActiveWorkbook.Sheets("Other")
  
  endrow = DAV.Range("A" & DAV.Rows.Count).End(xlUp).Row
  
  For i = 2 To endrow
  If DAV.Cells(i, "G").Value = "Other" And DAV.Cells(i, "K").Value = "To be Done" Then
  DAV.Cells(i, "G").EntireRow.Cut Destination:=OTH.Range("A" & OTH.Rows.Count).End(xlUp).Offset(1)
  End If
  
  Dim r As Long
  For r = ActiveSheet.UsedRange.Rows.Count To 1 Step -1
  If Application.CountA(Rows(r)) = Empty Then
  Rows(r).EntireRow.Delete
  End If
  Next r
  
  
  Next i
  End Sub

  
  
• ce même code est dupliqué sur plusieurs macros et utilisé sur la même feuille source (Demandes à traiter), la seule variable qui change est le nom de la feuille de destination/type de demande (Otherbis, Otherter, etc...).
  Ce code fonctionne très bien mais c'est un peu ennuyeux d'avoir à lancer 10 macros alors que le code est toujours le même, la seule différence entre celles-ci sont ces deux lignes qui changent:
  
  

  Set OTH = ActiveWorkbook.Sheets("[COLOR=rgb(243, 121, 52)][B]Otherbis[/B][/COLOR]")
  If DAV.Cells(i, "G").Value = "[B][COLOR=rgb(243, 121, 52)]Otherbis[/COLOR][/B]" And DAV.Cells(i, "K").Value = "To be Done" Then
  
  Set OTH = ActiveWorkbook.Sheets("[B][COLOR=rgb(251, 160, 38)]Otherter[/COLOR][/B]")
  If DAV.Cells(i, "G").Value = "[B][COLOR=rgb(251, 160, 38)]Otherter[/COLOR][/B]" And DAV.Cells(i, "K").Value = "To be Done" Then

En espérant avoir été clair je vous remercie par avance pour l'aide que vous pourriez m'apporter

 

[fanch55]

A Tester

 

[job75]

Bonsoir,

et que les lignes doivent ensuite disparaître de cette même feuille.

Testez ce fichier (2) et la macro dans le code de la feuille "Demandes à valider" :

Private Sub Worksheet_Change(ByVal Target As Range)
Dim P As Range, c As Range, w As Worksheet
If Application.CountIf([Status].EntireColumn, "To be Done") Then
    Application.ScreenUpdating = False
    Application.EnableEvents = False 'désactive les évènements
    With [Status].EntireColumn
        .Replace "To be Done", "#N/A", xlWhole
        Set P = .SpecialCells(xlCellTypeConstants, 16)
    End With
    On Error Resume Next 'si une feuille n'existe pas
    With [Motif].EntireColumn
        For Each c In P
            Set w = Nothing
            Set w = Sheets(CStr(.Cells(c.Row)))
            If w Is Nothing Then
                Set w = Sheets.Add(After:=Sheets(Sheets.Count)) 'crée la feuille
                w.Name = CStr(.Cells(c.Row))
            End If
            If w.Cells(1) = "" Then Rows(1).Copy w.Cells(1) 'ligne d'en-têtes
            If w.FilterMode Then w.ShowAllData 'si la feuille est filtrée
            With w.Cells(w.Rows.Count, 1).End(xlUp)(2)
                c.EntireRow.Copy .Cells
                .EntireRow.Replace "#N/A", "To be Done"
            End With
            w.Columns.AutoFit 'ajustement largeurs
        Next
    End With
    P.EntireRow.Delete
    Application.EnableEvents = True 'réactive les évènements
    Me.Activate
End If
End Sub

A+

 

[job75]

Bonjour le fil, le forum,

S'il y a un grand nombre de "To be Done" entrés sur une sélection multiple il vaut mieux utiliser :

Private Sub Worksheet_Change(ByVal Target As Range)
Dim d As Object, critere As Range, colStatus%, colMotif%, tablo, i, nf$, w As Worksheet, c As Range
If Application.CountIf([Status].EntireColumn, "To be Done") Then
    Set d = CreateObject("Scripting.Dictionary")
    d.CompareMode = vbTextCompare 'la casse est ignorée
    Set critere = UsedRange(2, UsedRange.Columns.Count + 2)
    Application.ScreenUpdating = False
    With [Status].CurrentRegion
        colStatus = [Status].Column - .Column + 1
        colMotif = [Motif].Column - .Column + 1
        tablo = .Value 'matrice, plus rapide
        Application.EnableEvents = False 'désactive les évènements
        On Error Resume Next 'si une feuille n'existe pas
        For i = 2 To UBound(tablo)
            If LCase(tablo(i, colStatus)) = "to be done" Then
                nf = CStr(tablo(i, colMotif))
                If Not d.exists(nf) Then
                    d(nf) = ""
                    Set w = Nothing
                    Set w = Sheets(nf)
                    If w Is Nothing Then
                        Set w = Sheets.Add(After:=Sheets(Sheets.Count)) 'crée la feuille
                        w.Name = nf
                    End If
                    If w.Cells(1) = "" Then .Rows(1).Copy w.Cells(1) 'ligne d'en-têtes
                    critere = "=AND(" & [Motif].Offset(1).Address(0) & "=""" & nf & """," & [Status].Offset(1).Address(0) & "=""To be Done"")"
                    .AdvancedFilter xlFilterInPlace, critere(0).Resize(2) 'filtre avancé
                    If w.FilterMode Then w.ShowAllData 'si la feuille est filtrée
                    Set c = w.Cells(w.Rows.Count, 1).End(xlUp)(2)
                    .SpecialCells(xlCellTypeVisible).Copy c
                    c.EntireRow.Delete 'supprime la ligne d'en-têtes copiée
                    w.Columns.AutoFit 'ajustement largeurs
                End If
            End If
        Next
        If FilterMode Then ShowAllData 'ôte le filtre avancé
        critere = ""
        Me.Activate
        '---supprime les lignes qui ont été copiées---
        [Status].EntireColumn.Insert 'colonne auxiliaire
        [Status].Cells(1, 0) = 1
        [Status].Cells(1, 0).Resize(.Rows.Count).DataSeries 'numérotation des lignes
        .Sort [Status], xlAscending, Header:=xlYes 'tri pour regrouper et accélérer
        [Status].EntireColumn.Replace "To be Done", "#N/A"
        [Status].EntireColumn.SpecialCells(xlCellTypeConstants, 16).EntireRow.Delete
        .Sort [Status].Cells(1, 0), xlAscending 'ordre initial
        [Status].Cells(1, 0).EntireColumn.Delete 'supprime la colonne auxiliaire
        Application.EnableEvents = True 'réactive les évènements
    End With
    With UsedRange: End With 'actualise les barres de défilement
End If
End Sub

Fichier (3), je l'ai testé avec les lignes 2:8 recopiées sur 70 000 lignes et 30 000 "To be Done".

La macro s'exécute chez moi en 6,4 secondes.

A+