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

 

[Dranreb]

Bonsoir.
S'agirait-il de ventiler toutes les lignes avec "To be Done" en colonne "K" dans des feuilles existant toujours et dont les noms sont en colonne "G" ?
Ma fonction Gigogne pourrait regrouper les données de façon à pouvoir l'écrire plus facilement.

 

[wishtolearn]

Hello,

Merci pour ta réponse.

Je joins un fichier pour exemple, je pense que ça sera plus simple à visualiser

 

[Dranreb]

Bonjour.
Mais vous ne répondez pas à la question, mais dans le fichier joint, toutes les noms de feuilles spécifiée en colonne "F" existent, et je suppose que lorsque vous voulez transférer les "To be Done", il faut les transférer tous. Peut-on mettre les plages sous forme de tableaux ?
Est_ce que ce serait gênant si à la fin du traitement les données restantes étaient classées sur la colonne "F" dans la feuille "Demandes à valider" ?

 

[wishtolearn]

Hello,

Merci pour la réponse.

Oui, le but est effectivement de transférer d'un coup toutes les lignes pour lesquelles en colonne H il y a "To be done" vers les feuilles portant le même nom que les motifs présents en colonne F, les other vers la feuille other, les otherbis vers la feuille otherbis

par contre les données restantes dans les autres lignes de la feuille "Demandes à valider"

j'espère que ça répond à votre question

 

[Dranreb]

Vous n'avez pas terminé votre seconde phrase soit par "peuvent être classées sur la colonne F" soit par "doivent rester dans leur ordre initial"
Et vous n'avez pas dit si je peux mettre des ListObject derrière ces plages, c'est à dire leur faire subir une 'Mise sous forme de tableau'.

 

[wishtolearn]

Vous n'avez pas terminé votre seconde phrase soit par "peuvent être classées sur la colonne F" soit par "doivent rester dans leur ordre initial"
Et vous n'avez pas dit si je peux mettre des ListObject derrière ces plages, c'est à dire leur faire subir une 'Mise sous forme de tableau'.

L'idéal serait de ne pas mettre les plages sous forme de tableau et que les données restent dans leur ordre initial.

 

[fanch55]

Bonjour,
En quoi cela vous gênerait-il de transformer les 3 feuilles en tableaux structurés ?

 

[Dranreb]

Je le ferais peut être comme ça.

 

[wishtolearn]

Merci pour vos réponses.

Dranreb, votre solution frise le génie car c'es exactement ça dont j'avais besoin, de plus je viens d'essayer de rajouter des valeurs et des onglets supplémentaires et ça fonctionne aussi, et ça conserve bien mes MFC. Vraiment trop cool cette gigogne

Par contre dans mon fichier final la colonne status K est en colonne 11 et non 8. J'ai modifié le VBA en changeant If TDon(LD, 8) = "To be Done" Then par If TDon(LD, 11) = "To be Done" Then mais je pense que ce n'est pas ça car j'obtiens un message d'erreur (runtime erreur 9)

J'y suis presque. Merci.

 

[fanch55]

Bonsoir,

Dans un autre registre pour curiosité : celui des tables structurées.

1. Ouvrez le fichier que vous avez posté,
2. Allez dans le vba et insérez dans un module le code ci-dessous .
3. Convertissez vos onglets en tables structurées avec la sub Convert_To_Tables ( à ne faire qu'une fois )
4. Utilisez votre bouton "déplacer Others" par la suite .

Nota: Les tables ont le même nom que les feuilles dans lesquelles elles sont ... Si vous deviez dupliquer une feuille par la suite, renommez également la table associée avec le nom de la feuille.

Option Explicit
Sub MoveTab()
Dim Vide    As Boolean
Dim Sht     As Worksheet
Dim oList   As ListObject
Dim Row     As Integer
Dim R       As Integer
Dim Target  As String
Dim Tables

' On établit une liste des tables existantes dans le Document
    Set Tables = CreateObject("Scripting.Dictionary")
    For Each Sht In ThisWorkbook.Worksheets
        For Each oList In Sht.ListObjects
            Tables.Add oList.Name, vbNullString
        Next
    Next
    
    [Valider].Parent.Activate
    For Row = 1 To [Valider].Rows.Count
        Select Case True
            Case [Valider[Status]].Rows(Row) <> "To be Done"
            Case Not Tables.Exists([Valider[Motif]].Rows(Row).Text)
            Case Else
                Target = [Valider[Motif]].Rows(Row)
                Vide = Range(Target).ListObject.ListRows.Count = 0
                Range(Target).ListObject.ListRows.Add
                R = Range(Target).ListObject.ListRows.Count
                [Valider].Rows(Row).Copy
                Range(Target).Rows(R).PasteSpecial Paste:=xlPasteValues
                [Valider].Rows(Row).Delete
                If Vide Then
                    Range(Target).ListObject.DataBodyRange.Interior.Pattern = xlNone
                    Range(Target).ListObject.DataBodyRange.Font.ColorIndex = xlAutomatic
                    Range(Target).ListObject.DataBodyRange.Font.Bold = False
                End If

        End Select
    Next
    [Valider].Parent.Activate
    [Valider[#Headers]].Activate
    
    Application.CutCopyMode = False
    Set Tables = Nothing
End Sub
Sub Convert_To_Tables()
      
    With ActiveWorkbook.TableStyles.Add("MonStyle")
        .ShowAsAvailablePivotTableStyle = False
        .ShowAsAvailableTableStyle = True
        .ShowAsAvailableSlicerStyle = False
        .ShowAsAvailableTimelineStyle = False
    End With
    
    With Sheets("Demandes à valider")
        .Cells.Font.Bold = False
        .ListObjects.Add(xlSrcRange, .Range("$A$1:$H$8"), , xlYes, , "MonStyle").Name = "Valider"
        .ListObjects("Valider").Range.AutoFilter
    End With
    
    Set_Table Sheets("Other")
    Set_Table Sheets("Otherbis")
    
    With Sheets("Macros")
        .Shapes("Button 3").OnAction = "MoveTab"
        .Activate
    End With
    
End Sub
Sub Set_Table(Sh As Worksheet)
    
    With Sh
        With .Rows("2:" & .Rows.Count)
            .Clear
            .Delete
        End With
        .Cells.FormatConditions.Delete
        .ListObjects.Add(xlSrcRange, .Range("$A$1:$H$2"), , xlYes, , "MonStyle").Name = .Name
        With .ListObjects(.Name)
            .Range.AutoFilter
            With .DataBodyRange.Columns("B:G")
                With .FormatConditions.Add(Type:=xlExpression, _
                    Formula1:="=ET($A2-AUJOURDHUI()>14;$H2<>""Done"")")
                    .Interior.Color = vbGreen
                End With
                With .FormatConditions.Add(Type:=xlExpression, _
                    Formula1:="=ET($A2-AUJOURDHUI()<=7;$H2<>""Done"")")
                    .Interior.Color = vbRed
                End With
                With .FormatConditions.Add(Type:=xlExpression, _
                    Formula1:="=ET($A2-AUJOURDHUI()>=8;$H2<>""Done"")")
                    .Interior.Color = vbYellow
                End With
            End With
            .DataBodyRange.Delete
        End With
    End With

End Sub

 

[Dranreb]

Peut être au début :

Set RngDon = Intersect(WshDàV.[A2:I1000000], WshDàV.UsedRange.EntireRow)

Sinon ça pourrait planter si la colonne I n'est renseignée nulle part, parce que la UserRange n'irait pas encore jusque là ?

 

[job75]

Bonjour wishtolearn, Bernard, fanch55,

Voyez le fichier joint et cette macro dans le code de ThisWorkbook :

Private Sub Workbook_SheetActivate(ByVal Sh As Object)
Dim a, P As Range
a = Array("Other", "Otherbis") 'liste à adapter
If IsNumeric(Application.Match(Sh.Name, a, 0)) Then
    Application.ScreenUpdating = False
    Sh.Cells.Delete 'RAZ
    With Sheets("Demandes à valider")
        Set P = .[A1].CurrentRegion
        P(2, P.Columns.Count + 2) = "=AND(" & [Motif].Offset(1).Address(0) & "=""" & Sh.Name & """," & [Status].Offset(1).Address(0) & "=" & """To be Done"")" 'critère
        P.AdvancedFilter xlFilterInPlace, P.Cells(1, P.Columns.Count + 2).Resize(2) 'filtre avancé
        P.SpecialCells(xlCellTypeVisible).Copy Sh.[A1]
        If .FilterMode Then .ShowAllData 'affiche tout
        P(2, P.Columns.Count + 2) = ""
    End With
    Sh.Columns.AutoFit 'ajustement largeurs
End If
End Sub

Elle se déclenche quand on active l'une des feuilles de la liste.

Ne pas oublier de nommer les cellules Motif et Status qui permettent le fonctionnement si l'on modifie la disposition des colonnes du tableau.

A+

 

[wishtolearn]

Hello,

Merci à vous trois de m'aider dans cette finalisation qui est loin d'être simple pour quelqu'un qui ne domine pas le vba.

Job75, votre code est top, le souci c'est que la feuille des demandes à traiter n'est pas vérouillée et que les personnes qui déclarent les status ne sont pas les mêmes et que les lignes doivent ensuite disparaître de cette même feuille.


Dranreb, j'ai procédé aux modifs mais j'ai tjs la même erreur. Je joins le fichier avec les colonnes dans l'ordre souhaité pour voir ce qui ne vas pas.

Merci.

 

[Dranreb]

Bonjour
L'erreur essentielle était que vous aviez laissé Gigogne(TOth, 6), alors que le nom de la feuille destinatrice est passé en colonne 7 (G).
Aussi au début on peut remettre Intersect(WshDàV.[2:1000000], WshDàV.UsedRange) puisque la ligne de titre définit la UsedRange au fond, tandis que WshDàV.[A2:I1000000] ne va pas jusqu'à la nouvelle colonne M.