Defusionner des cellules

Bonjour à tous,

J'ai des fichiers Excel à modifier en permanence et j'aurais voulu avoir de l'aide pour aller plus vite.

l'onglet AML est le fichier de base et dans la feuil 1 c'est le résultat attendu (juste le début)

Le but est de défusionner toutes les cellules de l'AML et de n'avoir qu'une seule valeur dans les colonne C, D, E (en couleur pour exemple)

Pouvez-vous m'aider?

Par avance merci.

Céd

Edit modo : modifié titre du sujet "Me simplifier le boulot". Merci de veiller à mettre un titre de sujet en rapport à votre demande

Bonjour,

si vous sélectionnez toutes les cellules des colonnes C, D, et E (à partir de la ligne 10) et que vous cliquez sur "Fusionner et centrer", ça va tout défusionner d'un coup.

Mais ça va dédoubler leur contenu, donc chaque nouvelle cellule sera remplie.

Bonjour,

Oui le but c'est ne de remplir que la première cellule à chaque fois.

Cordialement

Ced.

Bonjour,

Je pense que la macro ci-après devrait faire le travail demandé :

Public Sub CopierVersFeuille()
  Dim data As Variant
  With ThisWorkbook.Worksheets("AMLCEMReport").Range("A8").CurrentRegion
    data = .Value
    .Copy
  End With

  Dim i As Long, j As Long
  Dim lastVals(3 To 5) As String
  ' rows
  For i = LBound(data, 1) + 2 To UBound(data, 1)
    ' columns C to E
    For j = LBound(lastVals) To UBound(lastVals)
      If StrComp(lastVals(j), CStr(data(i, j)), vbTextCompare) = 0 Then
        ' cell is the same as last saved one
        data(i, j) = vbNullString
      Else
        ' cell is different, saving new last cell
        lastVals(j) = data(i, j)
      End If
    Next j
  Next i

  Application.ScreenUpdating = False
  With ThisWorkbook.Worksheets.Add().Range("A8")
    ' past all with formats
    .PasteSpecial xlPasteAll
    Application.DisplayAlerts = False
    ' columns widths
    .PasteSpecial xlPasteColumnWidths
    Application.DisplayAlerts = True
    Application.CutCopyMode = False
    ' unmerge
    Dim cellX As Range
    For Each cellX In .CurrentRegion
      If cellX.MergeCells Then cellX.UnMerge
    Next cellX
    ' cleaned data
    .Resize(UBound(data, 1), UBound(data, 2)).Value = data
  End With
  Application.ScreenUpdating = True
End Sub

Bonjour,

Cela fonctionne mais avec des bug.

sur certaine ligne la quantité a disparue

ligne 27, 31, 42...

cordialement

Ced

Ah oui vous avez raison j'avais appliqué une logique un peu "débile" qui faisait "tant que la valeur au dessus est identique, supprimer les données". La correction ci-dessous traite votre tableau en "blocs de cellules fusionnées", ce qui devrait correspondre davantage à votre demande.

Public Sub CopierVersFeuille()
  Dim data As Variant
  With ThisWorkbook.Worksheets("AMLCEMReport").Range("A8").CurrentRegion
    data = .Value
    .Copy
  End With

  Dim i As Long, j As Long
  Dim lastVals(3 To 5) As String
  ' rows
  For i = LBound(data, 1) + 2 To UBound(data, 1)
    ' reading column C value to check for duplicates
    If StrComp(lastVals(LBound(lastVals)), CStr(data(i, LBound(lastVals))), vbTextCompare) = 0 Then
      ' cell is the same as last saved one => we replace columns C,D,E (=3,4,5)
      For j = LBound(lastVals) To UBound(lastVals)
        data(i, j) = vbNullString
      Next j
    Else
      ' cell is different, saving new last cells
      For j = LBound(lastVals) To UBound(lastVals)
        lastVals(j) = data(i, j)
      Next j
    End If
  Next i

  Application.ScreenUpdating = False
  With ThisWorkbook.Worksheets.Add().Range("A8")
    ' past all with formats
    .PasteSpecial xlPasteAll
    Application.DisplayAlerts = False
    ' columns widths
    .PasteSpecial xlPasteColumnWidths
    Application.DisplayAlerts = True
    Application.CutCopyMode = False
    ' unmerge
    Dim cellX As Range
    For Each cellX In .CurrentRegion
      If cellX.MergeCells Then cellX.UnMerge
    Next cellX
    ' cleaned data
    .CurrentRegion.Value = data
  End With
  Application.ScreenUpdating = True
End Sub

Autre possibilité, vous sélectionnez et défusionnez les 3 colonnes comme je proposais plus tôt et ensuite vous activez ce code pour effacer les doublons (basé sur la colonne E, en admettant que la ref change à chaque fois) ;

Sub EffaDoublons()
    Application.EnableEvents = False
    For c = 315 To 10 Step -1
    If Sheets("AMLCEMReport").Range("E" & c).Value = Sheets("AMLCEMReport").Range("E" & c - 1).Value Then
    Sheets("AMLCEMReport").Range("E" & c).ClearContents
    Sheets("AMLCEMReport").Range("E" & c).Offset(0, -1).ClearContents
    Sheets("AMLCEMReport").Range("E" & c).Offset(0, -2).ClearContents
    End If
    Next c
    Application.EnableEvents = True
End Sub

Merci Saboh,

A première vu ça fonctionne et me fait gagner du temps.

Cordialement.

Ced

Je vous en prie, content d'aider. Si a posteriori la solution vous convient, n'oubliez pas de clôturer le post.

Bonne journée

PS @Doux rêveur : tu peux récupérer la boucle que j'ai utilisée pour défusionner les cellules directement dans ta macro

For Each cellX In .CurrentRegion If cellX.MergeCells Then cellX.UnMerge Next cellX

saboh12617 a écrit :

PS @Doux rêveur : tu peux récupérer la boucle que j'ai utilisée pour défusionner les cellules directement dans ta macro

For Each cellX In .CurrentRegion If cellX.MergeCells Then cellX.UnMerge Next cellX

Merci pour l'idée. J'ai dû un peu chercher pour le faire fonctionner, ceci marche ;

Sub EffaDoublons2()
    Application.EnableEvents = False
    With ThisWorkbook.Worksheets("AMLCEMReport").Range("A8").CurrentRegion
    For Each cellX In .CurrentRegion
    If cellX.MergeCells Then
    cellX.UnMerge
    End If
    Next cellX
    End With
    For c = 315 To 10 Step -1
    If Sheets("AMLCEMReport").Range("E" & c).Value = Sheets("AMLCEMReport").Range("E" & c - 1).Value Then
    Sheets("AMLCEMReport").Range("E" & c).ClearContents
    Sheets("AMLCEMReport").Range("E" & c).Offset(0, -1).ClearContents
    Sheets("AMLCEMReport").Range("E" & c).Offset(0, -2).ClearContents
    End If
    Next c
    Application.EnableEvents = True
End Sub

Merci Doux rêveur aussi pour ton aide.

Cordialement

Ced