RESOLU p... de cellules fusionnées

[pierrejean]

Bonjour à tous

Dans le cadre de ce fil:
https://www.excel-downloads.com/thr...iduelle-commissaire-tournoi-de-golf.20000058/

je me heurte à un problème que je peine à résoudre proprement
Il s'agit de définir en Vba l'adresse de groupes de cellules fusionnées

Le fichier joint sera je l’espère plus parlant

 

[job75]

Re : p... de cellules fusionnées

Bonjour Pierre, heureux de te croiser,

Sub a()
Dim c As Range, mes$
For Each c In ActiveSheet.UsedRange
If c <> "" And c.MergeArea.Count > 1 Then _
  mes = mes & vbLf & c & " : " & c.MergeArea.Address(0, 0)
Next
MsgBox Mid(mes, 2)
End Sub

Bonne journée.

 

[Pierrot93]

Re : p... de cellules fusionnées

Bonjour PierreJean

si j'ai bien compris ta demande, espérant que cela puisse te faire avancer :

Dim p As Range, c As Range
Set p = Range("B3:J8")
For Each c In p
    If Application.CountA(c.MergeArea) > 0 Then MsgBox c.MergeArea.Address
Next c

bonne journée
@+

Edition : bonjour Job

 

[DoubleZero]

Re : p... de cellules fusionnées

Bonjour, pierrejean , job75 , Pierrot , le Forum,

Une autre suggestion :

Option Explicit
Sub Fusion_où()
    Dim c As Range
    For Each c In Feuil1.UsedRange.Cells
        If c.MergeCells = True And c <> "" Then Range("q" & Rows.Count).End(xlUp)(2) = c.MergeArea.Address(0, 0)
    Next
    With Columns(17): .RemoveDuplicates Columns:=1, Header:=xlNo: .Sort [q1], Header:=xlNo: End With
End Sub

A bientôt

 

[job75]

Re : p... de cellules fusionnées

Re Pierre, bonjour Pierrot, bonjour chère ânesse,

Autre solution (avec SpecialCells) annulée car pas générale.

A+

 

[job75]

Re : p... de cellules fusionnées

Re,

Cette solution peut être plus rapide :

Sub Adresses()
Dim c As Range, mes$
'On Error Resume Next 'si c'était nécessaire
For Each c In Cells.SpecialCells(xlCellTypeBlanks)
If c <> "" Then mes = mes & vbLf & c & " : " & c.MergeArea.Address(0, 0)
Next
MsgBox Mid(mes, 2)
End Sub

A+

 

[PMO2]

Re : p... de cellules fusionnées

Bonjour,

Une autre approche en utilisant FindFormat

Option Explicit

Sub aa()
Dim R As Range
Dim C As Range
Dim FirstC As Range
'---
Set R = ActiveSheet.UsedRange
'---
Set C = R.Cells(1, 1)
Application.FindFormat.MergeCells = True
Do
  Set C = R.Find(What:="*", After:=C, LookIn:=xlValues, _
                 LookAt:=xlPart, SearchOrder:=xlByRows, _
                 SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=True)
  
  If C Is Nothing Then Exit Do
  If FirstC Is Nothing Then
    Set FirstC = C
  Else
    If C = FirstC Then Exit Do
  End If
  
  MsgBox C.MergeArea.Address(False, False)

Loop
End Sub

 

[job75]

Re : p... de cellules fusionnées

Re,

J'ai de la suite dans les idées alors je continue avec mes SpecialCells :

Sub Adresses1()
Dim P As Range, Q As Range, R As Range, c As Range, mes$
On Error Resume Next
Set P = Cells.SpecialCells(xlCellTypeConstants)
Set Q = Cells.SpecialCells(xlCellTypeFormulas)
Set R = Cells.SpecialCells(xlCellTypeBlanks)
If P Is Nothing Then Set P = Q
If Q Is Nothing Then Set Q = P
For Each c In Intersect(Union(P, Q), R)
If c <> "" Then mes = mes & vbLf & c & " : " & c.MergeArea.Address(0, 0)
Next
MsgBox Mid(mes, 2)
End Sub

Je pense que c'est la solution la plus rapide pour détecter les cellules fusionnées non vides.

Edit : salut PMO2.

A+

 

[mapomme]

Re : p... de cellules fusionnées

Bonjour à tous,

Un autre essai ? :

Sub test()
Dim xcell As Range
  For Each xcell In Range("b3:j8")
    If Not IsEmpty(xcell) Then If xcell.MergeArea.Address <> xcell.Address Then _
      MsgBox xcell.MergeArea.Address(0, 0) & " -> " & xcell.Value
  Next xcell
End Sub

Edit...

 

[job75]

Re : p... de cellules fusionnées

Re, bonjour mapomme,

J'ai copié les lignes 3:8 jusqu'à la ligne 6002.

Durées d'exécution sur Win 8 - Excel 2013 :

- macro du post #2 => 0,9 seconde

- macro du post #6 => 2,2 secondes

- macro du post #8 => 3,0 secondes.

C'est l'inverse de ce que je pensais...

A+

 

[pierrejean]

Re : p... de cellules fusionnées

Bonsoir

Merci Gerard
Merci Pierrot
Merci DoubleZero
Merci PMO2
Merci tapomme

Je suis de retour d'une petite excursion dans la région de mes ancêtres et je m’aperçois que cette grosse difficulté pour moi n'en est visiblement pas une pour vous

Je vous tiens au courant dès que j'aurais la possibilité d’étudier cela de plus pres

 

[ROGER2327]

Re : p... de cellules fusionnées

Bonsoir à tous.

Une autre, utilisant la propriété MergeCells :​

Sub toto()
Dim k&, x$(), Cel As Range
  With Selection
    If .Count > 1 Then
      ReDim x(1 To .Count / 2, 1)
      For Each Cel In .Cells
        If Not IsEmpty(Cel.Value) Then If Cel.MergeCells Then k = k + 1: x(k, 0) = Cel.MergeArea.Address(0, 0): x(k, 1) = Cel.Value
      Next
    End If
  End With
  If k Then [L6].Resize(k, 2).Value = x ' À adapter...
End Sub

Bonne nuit.


ℝOGER2327
#7991

Mercredi 4 Phalle 142 (Saint Mnester, confesseur - fête Suprême Quarte)
27 Thermidor An CCXXIII, 9,7312h - colsa
2015-W33-5T23:21:18Z

 

[pierrejean]

Re : p... de cellules fusionnées

Bonjour à tous

Merci ROGER

Toutes vos solutions qui, bien évidemment, donnent les résultats attendus m'ont appris le 'Mergearea'
Et en définitive dans le contexte (fil cité plus haut) Mergearea.count a résolu mon problème

Encore une fois Merci à tous

 

[job75]

Re : RESOLU p... de cellules fusionnées

Bonjour Pierre, Roger,

Si dans la macro du post #2 je remplace le test c.MergeArea.Count > 1 par c.MergeCells

c'est beaucoup plus long : 45 secondes au lieu de 0,9 seconde en testant comme en #10.

Bonne journée.

 

[job75]

Re : RESOLU p... de cellules fusionnées

Re,

Bien sûr si en #10 on fait les tests en cascade c'est plus rapide :

Sub a()
Dim t, c As Range, mes$
t = Timer
For Each c In ActiveSheet.UsedRange
If c <> "" Then If c.MergeArea.Count > 1 Then _
  mes = mes & vbLf & c & " : " & c.MergeArea.Address(0, 0)
Next
MsgBox Timer - t
MsgBox Mid(mes, 2)
End Sub

Sub b()
Dim t, c As Range, mes$
t = Timer
For Each c In ActiveSheet.UsedRange
If c <> "" Then If c.MergeCells Then _
  mes = mes & vbLf & c & " : " & c.MergeArea.Address(0, 0)
Next
MsgBox Timer - t
MsgBox Mid(mes, 2)
End Sub

a() => 0,28 seconde

b() => 2,4 seconde.

A+