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

Philippe LAMACHE

XLDnaute Junior
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.

VB:
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

XLDnaute Barbatruc
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
VB:
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

XLDnaute Junior
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 :mad: mais dans un autre fichier, oui :) (les voies du VBA sont impénétrables o_O - 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é :
VB:
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
 

Discussions similaires

Statistiques des forums

Discussions
311 720
Messages
2 081 920
Membres
101 840
dernier inscrit
SamynoT