XL 2010 Peut-on ne tester que la première cellule d'une fusion

[Philippe LAMACHE]

Bonjour à tous,

Dans mon code (ci-dessous), je détermine ma hauteur de ligne en fonction du nombre de caractères et de la largeur cumulée des colonnes de cellules fusionnées.

Sub Hauteurs_Lignes()
Feuil1.Activate
Art = "Calorifuge à démonter"
Div = 0.95
Mult = 18
With ActiveSheet.Range("A:D")
    Set Cellule = .Find(Art, LookAt:=xlPart)
    Cellule.Select
    Selection.Offset(0, 2).resize(10, 1).Select
    Range(ActiveCell, ActiveCell.Offset(20, 0).End(xlUp)).Select
End With
For Each c In Selection
    c.Select
    c.Value = UCase(c.Value)
    MonAD = c.Address(0, 0)
    Lig = ActiveCell.Row - 1
    larcol = Cells(Lig, 3).ColumnWidth + Cells(Lig, 4).ColumnWidth
    nbcarlgn = Application.WorksheetFunction.RoundDown(larcol / Div, 0)
    nbcar = Len(ActiveCell)
    nblgn = Application.WorksheetFunction.RoundUp(nbcar / nbcarlgn, 0)
    ActiveCell.Offset(0, 13).Value = nblgn * Mult
Autre:
Next
With ActiveSheet.Range("E:N")
    Set Cellule = .Find(Art, LookAt:=xlPart)
    Cellule.Select
    Selection.Offset(0, 2).resize(10, 1).Select
    Range(ActiveCell, ActiveCell.Offset(20, 0).End(xlUp)).Select
End With
For Each c In Selection
    If Len(c) = 0 Then GoTo Autre
    c.Select
    c.Value = UCase(c.Value)
    Unite = c.Value
    If Unite Like "*b*" Then Unite = Left(c.Value, InStr(c.Value, " ") - 1)
    If Unite > 1 And IsNumeric(Unite) Then
        c.Value = Unite & " Bars"
    ElseIf Unite = 1 And IsNumeric(Unite) Then
        c.Value = Unite & " Bar"
    Else
    End If
    Lig = ActiveCell.Row - 1
    larcol = Cells(Lig, 7).ColumnWidth + _
             Cells(Lig, 8).ColumnWidth + _
             Cells(Lig, 9).ColumnWidth + _
             Cells(Lig, 10).ColumnWidth + _
             Cells(Lig, 11).ColumnWidth + _
             Cells(Lig, 12).ColumnWidth + _
             Cells(Lig, 13).ColumnWidth + _
             Cells(Lig, 14).ColumnWidth
    nbcarlgn = Application.WorksheetFunction.RoundDown(larcol / Div, 0)
    nbcar = Len(ActiveCell)
    nblgn = Application.WorksheetFunction.RoundUp(nbcar / nbcarlgn, 0)
    ActiveCell.Offset(0, 4).Value = nblgn * Mult
autre:
Next
With ActiveSheet.Range("E:N")
    Set Cellule = .Find(Art, LookAt:=xlPart)
    Cellule.Select
    Selection.Offset(0, 1).resize(10, 1).Select
End With
For Each c In Selection
    c.Offset(0, 2).Select
    If ActiveCell.Value <> -1 Then ActiveCell.RowHeight = ActiveCell.Value
    If ActiveCell.Value = -1 Then ActiveCell.EntireRow.Delete
Next
Selection.CurrentRegion.ClearContents
End Sub

Mon souci c'est le code teste toutes les cellules de la fusion et cela peut prendre un peu de temps et est inutile vu que seulement la première cellule de la fusion est renseignée.

D'où ma question en objet : Peut-on ne tester que la première cellule d'une fusion et ignorer les autres ?

Par avance, merci.

 

[patricktoulon]

bonjour
exemple:
for each cel in range("A1:F20")
msgbox cel.cells(1).value
next

mais ca t'empechera pas de boucler sur toute les cellels de la fusion
il va te faloir stoker d'une maniere ou d'une autre les address de cellules visitées dans ta boucle avec un dico ou collection

 

[Philippe LAMACHE]

Merci patricktoulon,
Je craignais cette réponse...
Je vais faire avec car je ne peux pas "défusionner" mes cellules.
Et je ne fusionnerai PLUS JAMAIS de cellules, c'est trop de soucis !

 

[patricktoulon]

re
qui a parler de dé fusionner??c'est pas moi

 

[Philippe LAMACHE]

Re,

Mais ... heu ... c'était une bonne idée sur le moment, ça faisait joli !
Et après, le VBA est arrivé, sans se presser ...

 

[patricktoulon]

re
oui mais VBA sait faire ,pas toi 😉
allez a la façon patoche et sans dico
exemple vite fait a main levée en utilisant simplement le test intersect de ce qui a déjà été visité dans la boucle

Sub test()
    Set plage = Range("A1:F20") 'adapte ta plage ici
    Set memo = plage.Cells(1)
    For Each cel In plage.Cells
        If Intersect(memo, cel.MergeArea) Is Nothing Then
            txt = txt & cel.Cells(1).Address & " " & cel.Cells(1).Value & "-:-" & cel.MergeArea.Address & vbCrLf

            Set memo = Union(memo, cel.MergeArea)
        End If
    Next
    MsgBox txt
End Sub

tu verra il n'y a pas de doublons meme avec les fusionnées
c'est pas plus compliqué
😉

 

[Philippe LAMACHE]

Bonjour patricktouton,
Merci, cela convient bien pour ce que j'ai à traiter.

 

[Philippe LAMACHE]

Bonjour,

Pour information, et après quelques tests,
je me suis aperçu que la solution proposée par patricktouton ne prend pas en compte la 1ère cellule pour mon cas ici, non 😡 mais dans un autre fichier, oui 🙂 (les voies du VBA sont impénétrables 😵 - En tout cas par moi !).
Je n'ai pas réussi à résoudre ce problème de moi-même donc :
- Je dé-fusionne mes cellules
- Je traite mes hauteurs de lignes
- Je fusionne à nouveau mes cellules
Et cela fonctionne (même si ce n'est pas "très propre").
Donc, voici mon code corrigé :

Sub Hauteurs_Lignes_PE()
Feuil1.Activate
Art = "LISTE DES DOCUMENTS DEX"
Div = 0.95
Mult = 15.75
With ActiveSheet.Range("A:N")
    Set Cellule = .Find(Art, LookAt:=xlPart)
    Cellule.Select
    ActiveCell.CurrentRegion.Select
    Selection.Offset(1, 0).resize(Selection.Rows.Count - 1).Select
    Selection.Offset(, 0).resize(, 4).Select
    Selection.Borders(xlInsideVertical).LineStyle = xlNone
    Selection.Offset(0, 4).resize(, 10).Select
    Selection.Borders(xlInsideVertical).LineStyle = xlNone
    Selection.HorizontalAlignment = xlCenterAcrossSelection
End With
With ActiveSheet.Range("A:N")
    Set Cellule = .Find(Art, LookAt:=xlPart)
    Cellule.Select
    ActiveCell.CurrentRegion.Select
    Selection.Offset(1, 0).resize(Selection.Rows.Count - 1).Select
    Selection.MergeCells = False
    Selection.Offset(, 4).resize(, 1).Select
    Selection.Offset(0).resize(Selection.Rows.Count).Select
End With
For Each c In Selection
    c.Select
    nbligne = Len(c.Value) - Len(Application.WorksheetFunction.Substitute(c.Value, Chr(10), "")) + 1
    MaLig = ActiveCell.Row
    MaDerCol = Cells(MaLig, Columns.Count).End(xlToLeft).Offset(0, 1).Column
    If Len(c) = 0 And c.Offset(0, 2) = -1 Then
        Cells(MaLig, MaDerCol).Value = 15.75
    ElseIf Len(c) = 0 Then
        GoTo Autre
    Else
        Cells(MaLig, MaDerCol).Value = nbligne * Mult
    End If
Autre:
Next
With ActiveSheet.Range("A:N")
    Set Cellule = .Find(Art, LookAt:=xlPart)
    Cellule.Select
    ActiveCell.CurrentRegion.Select
    Selection.Offset(1, 0).resize(Selection.Rows.Count - 1).Select
    Selection.Offset(, 15).resize(, 1).Select
    Selection.Offset(0).resize(Selection.Rows.Count).Select
End With
For Each c In Selection
    c.Select
    If ActiveCell.Value <> -1 Then ActiveCell.RowHeight = ActiveCell.Value
    If ActiveCell.Value = -1 Then ActiveCell.EntireRow.Delete
Next
Selection.CurrentRegion.ClearContents
With ActiveSheet.Range("A:N")
    Set Cellule = .Find(Art, LookAt:=xlPart)
    Cellule.Select
    ActiveCell.CurrentRegion.Select
    Selection.Offset(1, 0).resize(Selection.Rows.Count - 1).Select
    Selection.Offset(, 0).resize(, 4).Select
    Selection.Borders(xlInsideVertical).LineStyle = xlNone
    Selection.Offset(0, 4).resize(, 10).Select
    Selection.Borders(xlInsideVertical).LineStyle = xlNone
    Selection.HorizontalAlignment = xlCenterAcrossSelection
End With
End Sub