macro pour copier, défusionner et .... Résolu

Question

Bonjour à tous (et toutes :-) )

voici le lien du fichier concerné par ma demande ci-dessous (ca n'est qu'un échantillon)

https://www.cjoint.com/c/MFAmxvZMydt

dans l'onglet feuill1 le fichier d'origine

dans l'onglet feuill2 le résultat dont j'aurai besoin

MA DEMANDE:

J'ai dans ce fichier les colonnes A et B qui fusionnent les cellules selon certaines données.

J'aurai besoin de trouver une macro qui puisse copier cet onglet mais sans fusionner les cellules et surtout en rappelant la donnée fusionnée sur chaque ligne concernée par cette donnée.

Je ne sais pas si je suis claire... c'est pourquoi j'ai mis le résultat dont j'aurai besoin en feuill2.

Mon fichier d'origine traite en réalité plus de 10 000 lignes c'est pourquoi je ne peux pas me permettre de le faire intégralement à la main sachant que je l'éditerai chaque semaine.

Merci d'avance pour votre aide :-)

ccm81 · Answer

Bonjour

Option Explicit

Const FS = "Feuil1"
Const FB = "Feuil2"
Const coage = 1
Const cocon = 2
Const lideb = 2

Public Sub ok()
Dim cel As Range, contrat As String, adr As String
Dim li As Long, lifin As Long, lili As Long
Application.ScreenUpdating = False
' copie de FS
Sheets(FS).Copy After:=Sheets(Sheets.Count)
ActiveSheet.Name = FB
' défusionnage colonne A
With Sheets(FB)
  lifin = .Cells.Find("*", , , , xlByRows, xlPrevious).Row
  li = lideb
  ' defusionner colonne agence
  For li = lideb To lifin
    If .Cells(li, coage).MergeCells Then
      .Cells(li, coage).MergeCells = False
      Set cel = .Cells(li, coage)
      While li < lifin And .Cells(li + 1, coage).Value = ""
        li = li + 1
        cel.Copy .Cells(li, coage)
      Wend
    End If
  Next li
  ' defusionner colonne contrats
  For li = lideb To lifin
    If .Cells(li, cocon).MergeCells Then
      .Cells(li, cocon).MergeCells = False
      Set cel = .Cells(li, cocon)
      While li < lifin And .Cells(li + 1, cocon).Value = ""
        li = li + 1
        cel.Copy .Cells(li, cocon)
      Wend
    End If
  Next li
End With
End Sub

La macro se charge de la copie de la feuille source (FS)

RQ. B13:B32 n'a pas de contrat et n'est pas fusionnée normal ?

Cdlmnt

ccm81 · Answer

j'ai oublié de joindre ton fichier pour test

https://www.cjoint.com/c/MFArwTFjLTB

Cdlmnt

ccm81 · Answer

a l'exception effectivement des contrats qui s'étendent sur les lignes là où n'y en avait pas.

ça m'apprendra à faire du zèle ;-)  du coup une version plus claire

https://www.cjoint.com/c/MFDm75Ihm7B

Cdlmnt

cousinhub29 · Answer

Bonjour,

Un autre code, qui ne prend en compte que les cellules fusionnées :

Sub defusion()
Dim Cel As Range, Plg As Range
For Each Cel In ActiveSheet.UsedRange
    If Cel.MergeCells Then
        Set Plg = Cel.MergeArea
        Cel.UnMerge: Plg.Value = Cel.Value
    End If
Next Cel
End Sub

Bonne journée

Macro pour copier, défusionner et ....

4 réponses

Discussions similaires

Newsletters