Microsoft Excel

Herbers Excel/VBA-Archiv

Informationen und Beispiele zum Thema InputBox
BildScreenshot zu InputBox InputBox-Seite mit Beispielarbeitsmappe aufrufen
Informationen und Beispiele zum Thema MsgBox
BildScreenshot zu MsgBox MsgBox-Seite mit Beispielarbeitsmappe aufrufen

Zellverbund aufheben (VBA)

Betrifft: Zellverbund aufheben (VBA) von: ing.grohn
Geschrieben am: 11.10.2014 20:51:18

Hallo Forum,
ich brauche jemanden der mir das vorm Kopf nimmt:
Ich übergebe eine Zelle an eine Prozedur. Dort muss ich den Zellverbund aufheben.
Ich weiss jetzt nicht wie ich das schreiben soll!!
normalerweise schreibe ich Range(A1:C1).MergeCells=False
Wie schreib ich das mit "Zelle" wenn A1 übergeben wird und die Zellen A1 B1 und C1 verbunden sind?
Vielen Dank für eine Antwort
Mit freundlichen Grüßen
Albrecht
(schei... verbundene Zellen)

  

Betrifft: AW: Zellverbund aufheben (VBA) von: Hajo_Zi
Geschrieben am: 11.10.2014 20:58:09

Hallo Albrecht,

Range("A1").MergeCells = False


GrußformelHomepage


  

Betrifft: AW: Zellverbund aufheben (VBA) von: ing.grohn
Geschrieben am: 11.10.2014 21:08:28

Hallo Hajo,
(es war das Brett was mir weggenommen werden sollte!)
wenn ich in der Prozedur bin kann ich nicht sagen: Range("A1").MergeCells = False
Denn wie gesagt es wird eine Zelle übergeben. Das kann A1 sein oder auch D1 oder B1
Also muß ich was mit cells und Zelle.row und .column sein.
und das fällt mir nicht ein!!
Mit freundlichen Grüßen
Albrecht


  

Betrifft: AW: Zellverbund aufheben (VBA) von: Hajo_Zi
Geschrieben am: 11.10.2014 21:25:18

Hallo Albrecht,
Dim Zelle As Range
Set Zelle = Range("A1")
Zelle.MergeCells = False

Gruß Hajo


  

Betrifft: Wenn wirklich eine Zelle übergeben wird, ... von: Luc:-?
Geschrieben am: 12.10.2014 00:47:13

…Albrecht,
also genaugenommen eine ZellReferenz, dann muss doch dafür eine ObjektVariable vom Typ Range existieren. Die kannst du dann auch direkt für Range benutzen. Ist das nicht der Fall, sollte wenigstens eine ZellAdresse übergeben wdn. Die kannst du dann als Variable (idR DatenTyp String) direkt in Range verwenden → Range(adressvariablenname). Rows und Columns benötigst du nur, wenn du Cells verwenden willst.
Allerdings wundert mich dieses „Brett (vorm Kopp)“ doch ziemlich, denn so etwas solltest du mittlerweile längst umsetzen können… ;-]
Gruß + schöSo, Luc :-?


  

Betrifft: AW: Wenn wirklich eine Zelle übergeben wird, ... von: ing.grohn
Geschrieben am: 12.10.2014 08:15:40

Hallo Hajo, Hallo Luc,
vielen Dank für die Antworten!
ja das ist schon sowas mit dem Brett.
Folgende Situation:
4 Zellen sind miteinander verbunden und enthalten A, F, K, U oder "nichts".
Je nach Farbe werden die Felder gefärbt oder nicht.
Dies geschieht mit:

Sub ZelleFaerben(Zelle As Range)
Application.EnableEvents = False
'with Zelle
     'Range(Cells(Zelle.Row, Zelle.Column), Cells(Zelle.Row, Zelle.Column + 3)).MergeCells =  _
False
     'Range(Cells(Zelle.Row, Zelle.Column)).Select 'Activate
     'Zelle.Select
     'MsgBox "GUCK2"
     Zelle.MergeCells = False
     Zelle.Select
     MsgBox "GUCK2"
     If Zelle.Value <> "" Then
     If UCase(Zelle.Value) = "K" Then
        Zelle.Interior.ColorIndex = 3
     ElseIf UCase(Zelle.Value) = "U" Then
        Zelle.Interior.ColorIndex = 4
     ElseIf UCase(Zelle.Value) = "A" Then
        Zelle.Interior.ColorIndex = 6
     ElseIf UCase(Zelle.Value) = "F" Then
        Zelle.Interior.ColorIndex = 7
     ElseIf Zelle.Value = "" Then
        Zelle.Interior.ColorIndex = xlNone
     End If
     Else
        Zelle.Interior.ColorIndex = xlNone
     End If
     Range(Cells(Zelle.Row, Zelle.Column), Cells(Zelle.Row, Zelle.Column + 3)).MergeCells =  _
True
'End With
Application.EnableEvents = True

End Sub

das funktioniert auch sehr schön!
nur, wenn ich den Inhalt lösche kommt die Fehlermeldung:"Typen unverträglich"
liegt wohl an der Verbundenheit"
gehe ich hin und hebe den Verbund "händisch" auf, positioniere den Cursor in die erste Zelle des Verbunds und lösche den Inhalt, TUTS!
Ich schätze das geht wohl nicht anders oder!!??
Mit freundlichen Güßen
Albrecht
einen schönen Sonntag


  

Betrifft: AW: Wenn wirklich eine Zelle übergeben wird, ... von: {Boris}
Geschrieben am: 12.10.2014 09:52:06

Hi,

Ich schätze das geht wohl nicht anders oder!!??

Doch - verzichte auf die verbundenen Zellen. Wieder ein "Beleg" mehr, wie die Dinger nichts als Ärger machen.
Weshalb gibt es Deiner Meinung nach keine Alternative OHNE verbundene Zellen?
Zeig doch mal Deine Datei ;-)

VG, Boris


  

Betrifft: AW: Wenn wirklich eine Zelle übergeben wird, ... von: ing.grohn
Geschrieben am: 12.10.2014 10:48:27

Hallo Boris,
es ist halt wg der Optik:



und das Problem entsteht "nur" beim Entfernen des Inhalts (schön blöd)

Mit freundlichen Grüßen
Albrecht


  

Betrifft: AW: Wenn wirklich eine Zelle übergeben wird, ... von: {Boris}
Geschrieben am: 12.10.2014 10:53:04

Hi Albrecht,

ich würde mindestens alle waagerechten Zellen "entbinden" und stattdessen das Zellformat "über Auswahl zentrieren" nutzen. Das sieht optisch dann genau so aus.
Spricht was dagegen?

VG, Boris


  

Betrifft: AW: Wenn wirklich eine Zelle übergeben wird, ... von: ing.grohn
Geschrieben am: 12.10.2014 11:17:39

Hallo Boris,
NEIN überhaupt nicht!!!!
Ich wünsche einen schönen Sonntag
(und ich färb nur noch die Nachbarzellen und habe fertig)
Mit freundlichen Grüßen
Albrecht


  

Betrifft: AW: Wenn wirklich eine Zelle übergeben wird, ... von: Daniel
Geschrieben am: 12.10.2014 11:54:20

Hi
Du kannst deine Zellverbünde behalten.
Du musst nur entsprechend programmieren, und beachten, dass man einen Zellverbund immer als ganzes bearbeiten sollte und nie nur einen Teil davon.

Das zweite was du beachten musst ist, dass der Ausdruck If UCase(Zelle.Value) = "K" nur dann funktioniert, wenn "Zelle" nur genau eine Zelle gross ist. Umfasst der Zellbereich von Zelle mehrere Zellen, dann erzeugt das .Value keinen Einzelwert, sondern ein zweidimensionales Array!
Mit einem zweidimensionalen Array misst du aber anders umgehen als mit einem Einzelwert, daher wahrscheinlich der Fehler.

Wenn nicht auszuschließen ist, dass Zelle mehrere Zellen gross ist (und das ist hier ja der fall), muss man also Zelle.Value vermeiden.
Entweder du beziehst dich explizit auf die erste Zelle des Bereichs, oder du verwendest nur Methoden, die mehrzellen-tauglich sind.

Probiere mal dass, hier werden über eine Schleife die Zellen vereinzelt und beim Färben wird der Zellverbünde berücksichtigt, so dass du deine Formatierung nicht ändern musst:

Sub ZelleFaerben(Zelle As Range)
Dim ZelleX As Range
For Each ZelleX In Intersect(Zelle, Zelle.Worksheet.UsedRange)
    With ZelleX.MergeArea
        Select Case LCase(.Cells(1, 1).Value)
            Case "k": .Interior.ColorIndex = 3
            Case "u": .Interior.ColorIndex = 4
            Case "a": .Interior.ColorIndex = 6
            Case "f": .Interior.ColorIndex = 7
            Case Else: .Interior.ColorIndex = xlNone
        End Select
    End With
Next
End Sub
Gruß Daniel


  

Betrifft: Ich bin aber der falsche Adressat... von: {Boris}
Geschrieben am: 12.10.2014 12:28:14

Hi Daniel,

...zudem halte ich alle diesbezüglichen Codes für einen Hilferuf eines "VBA-bescheiden-Levels" als ungeeignet.
Dass Du weißt, wie das geht, ist mir klar. Ich weiß es auch. Aber für den eher unerfahrenen Anwender halte ich zumindest den Hinweis auf die Probleme (und auch deren präventiver Vermeidung) für angemessen.
Tut mir leid, aber Deine Art zu posten kommt bei mir öfter so an wie: "Alles dummes Geschwätz - ich zeig Dir jetzt, wie das geht" ("Du kannst Deine Zellverbünde behalten - [hör nicht auf die anderen...]"...)

Sicher ist das nicht Deine Absicht - aber es kommt bei mir eben mitunter so an.

VG, Boris


  

Betrifft: Albrecht stellt hier schon seit Jahren Fragen ... von: Luc:-?
Geschrieben am: 12.10.2014 13:05:06

…und befindet sich immer noch auf diesem Level (oder gibt es nur an?), Boris,
das gibt Einem schon zu denken… ;-]
Ich vermute mal, dass ihm das Pgmieren zwar Spaß macht, aber andererseits auch schwer fällt. Da würde er also doch abundzu einen Denkanstoß benötigen, zB wie man solche Probleme lösen kann. Allerdings muss den nun wirklich nicht und unbedingt Daniel (auf seine übliche, zumindest dir und mir „auffällige“ Art, die möglicher­weise zT seinem Antworten per Handy geschuldet ist) liefern.
Ansonsten s.u.!
Gruß, Luc :-?


  

Betrifft: AW: Ich bin aber der falsche Adressat... von: Daniel
Geschrieben am: 12.10.2014 13:45:55

Hi
Naja, irgendwo muss den Beitrag ja im Baum aufhängen.
Da es eine Eigenart dieses Forums ist, dass beim Antworten nicht der Beitrag, auf den man sich bezieht direkt zu lesen ist sondern der Vorvertrag, führt schon mal dazu, dass man da verrutscht.

Meiner Ansicht nach lassen sich Verbundene Zellen in VBA sehr gut bearbeiten, wenn man die passenden Befehle kennt.
Ein Großteil ist Albrecht ja schon bekannt, wie sein verwendeter Code zeigt, er muss hier lediglich noch die Funktion .MergeArea hinzunehmen, welche eine Zellbereichs auf alle Zellen erweitert, die mit diesem verbunden sind. Das ist jetzt auch nicht komplizierter als ein .CurrentRegion, und damit durchaus mit dem VBA-Level "bescheiden" vereinbar.

Dass Sachen wie Range(...).Value = "Wert" nur dann funktionieren, wenn die Range aus einer Zelle besteht, muss man sowieso beachten.

Gruß Daniel


  

Betrifft: Das ist kein 'Beleg' gg (sinnvolle) VbZellen, ... von: Luc:-?
Geschrieben am: 12.10.2014 11:45:09

…Boris,
sondern nur für Ungeschick und Unkenntnis vieler derjenigen, die sie anwenden! Dass man das auch anders handhaben kann, siehst du wieder mal hier! ;-]
Gruß+schöSo, Luc :-?


  

Betrifft: Hehe... von: {Boris}
Geschrieben am: 12.10.2014 13:11:07

Hi Luc,

ich mach mir mal den Spaß, und kopier den Code auch hier direkt rein.
Das ist für die meisten doch sicher eine Nummer zu hoch...? ;-))

Aber na klar kann man das eben so korrekt händeln ;-)

VG, Boris

Rem Vbindet Zellen gleich Inhalts in d.m.Namen lt Var naVBer benannt Spalte;
'   dabei bleibt Inhalt aller VbZellen unvändert erhalt, Formate wdn übnomm;
'   alternativ kann auch nur d.1.existd Wert oder alle (ggf m.Trenner vbund)
'   in die 1.Zelle (zu drn Formaten) d.ZellVbunds übnommen wdn - in dsm Fall
'   könn d.VbZellen anschld wieder getrennt und irrelev Zeilen gelöscht wdn.
'   Achtung! Neben d.letzt Spalte d.insgesamt benutzten BlattBereichs müssen
'   sich noch ungenutzte Spalten lt Konst relHSpPos, deren letzte als tempo-
'   rärer ArbBereich benötigt wird, befind! Dse Spalte wird letztendl wieder
'   entfernt. Außerdem darf d.letzte TabSpaltenZeile nicht d.letztmögl sein!
'   Achtung! Bei Aufruf aus and Pgmm bzw Verwendung zusätzl speziell RufPgmm
'   m.Param-Übgabe wdn Hinwse/Fehler ggf nur im VBE-DirektFenster angezeigt!
'   Vs1.3 -LSr.CyWorXxl -cd:20140622 -1TotPub:20140808 Ol-Xl -lupd:20140807n

Const minAnzAwZ As Long = 2, naVBer$ = "VZAktSpBer"
Enum xlTriState: xlTrue = -1: xlFalse: xlCTrue: End Enum

Rem Alternatives RufPgm zur Anzeige der Pgm/Hilfe-Info
Sub VZSpHInfo()
    On Error Resume Next: Call VZellenSp(1, True)
End Sub

Rem Alternatives RufPgm zum Auflösen von VbZellen
Sub VZSpTrenn()
    On Error Resume Next: Call VZellenSp(, True)
End Sub

Rem DienstPgm zum Entfernen von Leerzeilen (zB nach VbZellenAuflösung)
'   Entfern aller im benannt (Ausw-)VglsBereich leeren Ausw/Bl-Zeilen!
'   Achtung! Dadurch kann sich d.Bezug eines direkt benannten Bereichs
'   vändern, weshb besser benannte INDIREKT-Fml m.TextAdr vwendt wird!
Sub LeerZeilEntf()
    Dim cct(1) As Long, rct(1) As Long, kalkStat As XlCalculation, avRvb As Variant, _
        lBer As Range, rVb As Range, vBer As Range, wBer As Range, aSh As Worksheet
    On Error GoTo fx: Set aSh = ActiveSheet
    With Application
        .ScreenUpdating = False: .EnableEvents = False
        kalkStat = .Calculation: .Calculation = xlCalculationManual
    End With
    On Error Resume Next
    If IsError(aSh.Names(naVBer)) Then
        On Error GoTo fx: Set vBer = ActiveWindow.RangeSelection
    Else: On Error GoTo fx: Set vBer = aSh.Range(naVBer)
    End If
    cct(1) = vBer.Columns.Count: rct(1) = vBer.Rows.Count
    With ActiveWindow.RangeSelection
        cct(0) = .Columns.Count: rct(0) = .Rows.Count
        If .Rows(1).Row = vBer.Rows(1).Row And rct(0) >= rct(1) And _
            cct(0) >= minAnzAwZ And cct(0) > cct(1) Then Set wBer = .Rows
    End With
    For Each rVb In vBer.Rows
        If cct(1) > 1 Then
            With WorksheetFunction: avRvb = .Transpose(.Transpose(rVb.Cells)): End With
            If Join(avRvb, "") = "" Then GoTo sl
        ElseIf IsEmpty(rVb.Cells(1)) Then
sl:         If Not wBer Is Nothing Then
                If Not lBer Is Nothing Then
                    Set lBer = Union(lBer, wBer.Rows(rVb.Row - wBer.Rows(1).Row + 1))
                Else: Set lBer = wBer.Rows(rVb.Row - wBer.Rows(1).Row + 1)
                End If
            ElseIf Not lBer Is Nothing Then
                Set lBer = Union(lBer, rVb.EntireRow)
            Else: Set lBer = rVb.EntireRow
            End If
        End If
    Next rVb
    If Not lBer Is Nothing Then lBer.Delete xlShiftUp
fx: If CBool(Err.Number) Then MsgBox Err.Description, vbCritical, "Fehler " & Err.Number
ex: With Application
        .ScreenUpdating = True: .EnableEvents = True: .Calculation = kalkStat
    End With
    Set aSh = Nothing: Set lBer = Nothing: Set vBer = Nothing: Set wBer = Nothing
End Sub

Rem UDF zur Ermittl der (unregelmäßigen) BlockStruktur 1es Bereichs
'   (auf StandOrtAdresse kann in VbZSpFestZ-InputBox verwiesen wdn)
'   Arg1: strukturrelev ZBereich; Arg2: Inhalt(smuster) nach/vorge-
'   ordneter Zeilen; Arg3: diese auf Arg2-Gleichh, sonst auf Muster
'   prüf; Arg4: struktrelev Inhalte in 1.(Default=1), sonst letzter
'   Zeile (=0, zentrt nur üb klass VbZelle mögl); Arg5: Ausgabe als
'   hor/vert (±1/2) MxKonstVekt (>0 lokal), sonst ListenForm (fehlt
'   /TextZ=,/TrennZ); Arg6: b.regelmäßg Wdhol 1er TeilFolge nur dse
'   ausgeben -> ohne Arg2/3 in Abhängigkeit v.Arg4 Vgl m.Vorgänger-
'   /NachfolgerZelle (wobei d.HptPgm in dsm Fall u.b.Verbleib aller
'   Werte in ihrer Zelle o.Angabe auch direkt aufgerufen wdn kann).
Function VertStruct(RefBereich As Range, Optional ByVal irrelRefBerInhalt = "", Optional _
                    ByVal irrInhGleich As Boolean, Optional ByVal relRefBerInhOb As Boolean = _
                    True, Optional ByVal alsMxKonst, Optional ByVal nurWdhFolge As Boolean)
    Const patMxKonst$ = "{#}"
    Dim isDivIrrCont As Boolean, isMx As Boolean, isMxK As VbTriState, isVgNf As xlTriState, _
        pix As Long, RowCt As Long, TrZ As String, irC As Variant, xR As Range, xrC As Range
    On Error GoTo fx
    isMx = RefBereich.Columns.Count > 1: isDivIrrCont = IsArray(irrelRefBerInhalt)
    If Not IsMissing(alsMxKonst) Then
        If IsNumeric(alsMxKonst) Then isMxK = Fix(alsMxKonst) Mod 3 Else TrZ = alsMxKonst
    Else: TrZ = ","
    End If
    With Application
        If isMxK > vbFalse Then
            TrZ = Array(.International(xlColumnSeparator), _
                        .International(xlRowSeparator))(isMxK Mod 2)
        ElseIf isMxK < vbFalse Then
            TrZ = Mid(",;", 3 + isMxK, 1)
        ElseIf TrZ = "" Then
            TrZ = .International(xlListSeparator)
        End If
    End With
    If Not isDivIrrCont Then
        If irrelRefBerInhalt = "" And Not irrInhGleich Then _
            irrInhGleich = True: isVgNf = xlCTrue + 2 * CInt(relRefBerInhOb)
    End If
    If isVgNf = xlFalse And Not isDivIrrCont Then irC = irrelRefBerInhalt
    For Each xR In RefBereich.Rows
        If isMx Then
            For Each xrC In xR.Cells
                On 1 - CInt(isDivIrrCont) GoSub wi, di
            Next xrC
        ElseIf isDivIrrCont Then
            Set xrC = xR
di:         For Each irC In irrelRefBerInhalt
                If (irrInhGleich And xrC = irC) Or _
                    (Not irrInhGleich And xrC Like irC) Then Exit For
            Next irC
            If IsEmpty(irC) Then GoTo wn Else RowCt = RowCt + 1
            If isMx Then Return
        Else: Set xrC = xR
wi:         If CBool(isVgNf) Then
                With RefBereich
                    If xrC.Row <> .Rows(IIf(isVgNf = xlTrue, 1, .Count)).Row Then
                        If xrC = xrC.Offset(isVgNf) Then RowCt = RowCt + 1 Else GoTo wn
                    Else: GoTo wn
                    End If
                End With
            ElseIf (irrInhGleich And xrC = irC) Or (Not irrInhGleich And xrC Like irC) Then
                RowCt = RowCt + 1
            Else
wn:             RowCt = RowCt - CInt(Not relRefBerInhOb)
                If CBool(RowCt) Then VertStruct = VertStruct & TrZ & CStr(RowCt)
                RowCt = Abs(relRefBerInhOb)
            End If
            If isMx Then Return
        End If
    Next xR
    If relRefBerInhOb Then VertStruct = VertStruct & TrZ & CStr(RowCt)
    If nurWdhFolge Then
        pix = InStr(Len(TrZ) + 1, VertStruct, TrZ & Split(VertStruct, TrZ)(1) & TrZ)
        If CBool(pix) Then
            Do While Not WorksheetFunction.Rept(Left(VertStruct, pix - 1), _
                    Len(VertStruct) \ (pix - 1) + 1) Like VertStruct & "*"
                pix = InStr(pix + Len(TrZ), VertStruct, TrZ & Split(VertStruct, TrZ)(1) & TrZ)
                If pix >= Len(VertStruct) - Len(TrZ) Then pix = 0
                If pix = 0 Then Exit Do
            Loop
            If CBool(pix) Then VertStruct = Left(VertStruct, pix - 1)
        End If
    End If
    VertStruct = Mid(VertStruct, Len(TrZ) + 1)
    If CBool(isMxK) Then VertStruct = Replace(patMxKonst, "#", VertStruct)
fx: If CBool(Err.Number) Then VertStruct = CVErr(Err.Number)
    Set xrC = Nothing
End Function

Rem Bsp für spezielles RufPgm zur Vermeidung von Input- bzw MsgBox
'   Arg1 muss (auf) relev SpStruktur (VertStruct) enthalt(/vweis)!
Sub RufVZSFZ()
    Call VZSpFestZ("a22", -2, 7)
End Sub

Rem Alternat Vor- u.RufPgm f.FestAnzahl(-Folge) zu vbindnder Zellen
'   Bei Aufruf d.Pgms m.Parameter1 entfällt d.Eingabe per InputBox!
'   1gegeb Anzahl (nicht Adresse/Trenner!) bleibt währd 1 XlSitzung
'   erhalt, b.Abbruch wird auf Default defZAnz rückgestellt. Auch 1
'   komma- bzw semikolon-getrennte Liste v.Anzahlen (auch in MxKon-
'   stantForm - unabdingb b.enthalt Elementt<2) kann angegeben oder
'   auf dse (ggf inkl Trenner) vwiesen wdn. Bei InhalteSammlg in 1.
'   Zelle d.ZVerbunds b.Bed Trenner (Zchn/Text/Zahl[enflg m.LeerZ])
'   angeb (fehlt->Default: lokalListTrennZch, []=ohne, weitere auch
'   m.ihrer CodeNr, zB [13 10- 32]=ZeilenSchalt m.nflgd Anstr+ZwR)!
'   Spezielle RufPgmm m.ParamÜbgabe könn hier b.Bedarf vwendet wdn:
'   oP1: zu vbindd ZeilAnz or AnzFolge als MxKonst-/AdressVweisTxt;
'   oP2=ZellVbModus: fehlt/0 alle Inhalte vbleib an ihrer Posit, ±1
'   nur 1.Wert erhalt (klass), ±2 Werte in 1.Zelle komb (1+2 m.Lee-
'   ren d.FolgeZ); oP3=Bhdl v.MxFmln (b.oP2<>0): fehlt/2/5 PgmAbbr,
'   ab 1.MxFml in 1.VbZelle 0/3/6 alles, 1/4/7 nur ds Block n.oP2=0
Sub VZSpFestZ(Optional ByVal InputText, Optional ByVal ZVbMod, Optional ByVal MxFMan)
    Const defZAnz$ = "2;…(ggf ListenAdresse)[Trennzeichen]", fAnz$ = "???", _
          fxStrErm$ = "VertStruct", korZusTxt$ = " Bitte überprüfen!", _
          liErsZ = ".\", lkZAnzAd$ = "[A-Za-z]*#*", lkZAnzGn$ = "*#*[[]*", _
          lkZAnzLi$ = "#*#[,;]#*#", lkZAnzMx$ = "{#*#[,;]#*#}"
    Static TrZ As String, lzZAnz As Variant
    Dim hasIpTx As Boolean, isAdr As Boolean, isErr As Boolean, isList As Boolean, _
        isMxKonst As Boolean, iw, tz, avPrf As Variant
    On Error Resume Next: If IsEmpty(lzZAnz) Then lzZAnz = defZAnz
    TrZ = Application.International(xlListSeparator)
    hasIpTx = Not IsMissing(InputText): If hasIpTx Then lzZAnz = InputText: GoTo ni
ip: If isErr And isAdr Then lzZAnz = avPrf
    lzZAnz = InputBox("Diverse Inhalte der zu verbindenden Zellen blei-" & vbLf & _
                      "ben ggf erhalten. Bitte ihre Anzahl > 1 bzw zu " & _
                      vbLf & "wiederholende Liste von Anzahlen angeben!" & _
                      vbLf & "(Zur Totalermittlung unregelmäßiger Anzahlen " & _
                      vbLf & "UDF '" & fxStrErm & "' benutzen u. hier die Ergebnis-" & _
                      vbLf & "adresse eintragen! Bei Inhaltesammlung in der " & _
                      vbLf & "1.Zelle des Verbunds ggf Trennzeichen [als Text] " & _
                      vbLf & "bzw CodeNr[-Folge mit Leerzeichen] zufügen!)", _
                      IIf(isErr, "Korrektur Zellenanzahl erforderlich!", "Verbund" & _
                      "zellen mit fester Zellenanzahl"), IIf(isErr, fAnz, lzZAnz))
    If lzZAnz = "" Or lzZAnz = fAnz Then
        lzZAnz = Empty: Exit Sub
    ElseIf lzZAnz = defZAnz Then
        lzZAnz = Left(lzZAnz, 1) & "[" & TrZ & "]": GoTo ip
    ElseIf CBool(InStr(lzZAnz, korZusTxt)) Then
        lzZAnz = Replace(lzZAnz, korZusTxt, "")
    End If
ni: If lzZAnz Like lkZAnzGn Then lzZAnz = Split(lzZAnz, "["): TrZ = _
        Split(lzZAnz(1), "]")(0): lzZAnz = Trim(lzZAnz(0))
    isAdr = lzZAnz Like lkZAnzAd
    If isAdr Then
        If IsError(Range(lzZAnz)) Then isErr = True: On 1 - CInt(hasIpTx) GoTo ip, ex
        avPrf = lzZAnz: lzZAnz = Range(lzZAnz)
        On Abs(lzZAnz Like lkZAnzGn) GoTo ni
    End If
    If Right(TrZ, 1) = " " Then TrZ = RTrim(TrZ) & " "
    If IsNumeric(Replace(TrZ, "-", "")) Then
        If CBool(InStr(TrZ, " ")) Then
zt:         For Each tz In Split(TrZ)
                If CLng(tz) >= 0 Then       'Anm: 0 hat gleiche Wirkung wie Wegfall d.and Werte! _

                    If IsNumeric(Replace(TrZ, "-", "")) Then _
                        TrZ = ChrW(CLng(tz)) Else TrZ = TrZ & ChrW(CLng(tz))
                ElseIf Not IsNumeric(Replace(TrZ, "-", "")) Then
                    If Right(tz, 1) = "-" Then
                        TrZ = TrZ & ChrW(Abs(tz)) & "-"
                    Else: TrZ = TrZ & "-" & ChrW(Abs(tz))
                    End If
                ElseIf Right(tz, 1) = "-" Then
                    TrZ = ChrW(Abs(tz)) & "-"
                Else: TrZ = "-" & ChrW(Abs(tz))
                End If
            Next tz
        ElseIf Not IsNumeric(TrZ) Then
            TrZ = Replace(TrZ, "-", "- "): GoTo zt
        ElseIf CLng(TrZ) >= 0 Then
            TrZ = ChrW(CLng(TrZ))
        ElseIf Right(TrZ, 1) = "-" Then
            TrZ = ChrW(Abs(TrZ)) & "-"
        Else: TrZ = "-" & ChrW(Abs(TrZ))
        End If
    End If
    If Not IsNumeric(lzZAnz) Then lzZAnz = _
        Replace(Replace(lzZAnz, Left(liErsZ, 1), ","), Right(liErsZ, 1), ",")
    If CBool(InStr(lzZAnz, ",")) Or Not IsNumeric(lzZAnz) Then
        isMxKonst = lzZAnz Like lkZAnzMx
        If Not isMxKonst Then
            isList = lzZAnz Like lkZAnzLi
            If isList Then avPrf = Evaluate(Replace(lkZAnzMx, lkZAnzLi, lzZAnz)) _
                Else isErr = True: GoTo ip
        Else: avPrf = Evaluate(lzZAnz)
        End If
        If IsError(avPrf) Or isAdr Then lzZAnz = Empty: If IsError(avPrf) Then _
            isErr = True: GoTo ex
        For Each iw In avPrf
            If Not IsNumeric(iw) Then Exit For
            If Fix(iw) <> CDbl(iw) Or Fix(iw) < CLng(Left(defZAnz, 1)) + _
                CInt(isMxKonst) Then Exit For
        Next iw
        If IsEmpty(iw) Then
            If IsError(LBound(avPrf, 2)) Then Else _
                avPrf = WorksheetFunction.Transpose(avPrf)
        Else: lzZAnz = iw: GoTo fx
        End If
    ElseIf CLng(lzZAnz) < CLng(Left(defZAnz, 1)) Then
fx:     isErr = hasIpTx: On Abs(isErr) GoTo ex
        MsgBox "Unzulässiger Wert!", vbCritical, "Input(-Element)=" & lzZAnz: _
            lzZAnz = Empty: GoTo ex
    Else: avPrf = Abs(Fix(lzZAnz))
    End If
    If hasIpTx Then
        If IsMissing(ZVbMod) Then ZVbMod = 0
        If Not IsNumeric(ZVbMod) Then ZVbMod = 0
        If CBool(ZVbMod) Then
            If Not IsMissing(MxFMan) Then
                If IsNumeric(MxFMan) Then
                    MxFMan = (Abs(MxFMan) Mod 6) Mod 3
                    MxFMan = MxFMan + 6 * (1 - MxFMan \ 2)
                Else: MxFMan = 2
                End If
            Else: MxFMan = 2
            End If
            Call VZellenSp(avPrf, , TrZ, ZVbMod, MxFMan)
        Else: Call VZellenSp(avPrf, , TrZ, ZVbMod)
        End If
    Else: Call VZellenSp(avPrf, , TrZ)
    End If
    isErr = False
ex: If isErr Then lzZAnz = Empty: Debug.Print "InputText »" & InputText & "« ggf fehlerhaft!"
End Sub

Rem HptPgm zum Erzeugen spaltenbezogener VbZellen
'   Möglichkeiten f.Konst 'VZvAlign':
'   0 -> wie eingestellt, 1 -> Tausch xlBottom gg xlTop u.umgekehrt
'   …sonst immer nur lt Konst -> xlTop | xlCenter | xlBottom
'   f.Konst relHSpPos (HilfsspPosit) kann belieb realist Wert ab 1,
'   f.Konst minAnzAwZ (ZellAuswVorrg vor defName) ab 2 angegeb wdn.
'   TabDaten sollten wg ZellRahmenFormatrg nicht m.Zeile1 beginnen!
'   FormatÜbtragg löst 'Change'-Ereignis aus, DirektFormatrg nicht!
'   optParam1…5 s.RufPgmm, optParam4+5 nur b.VollAutomat erforderl!
'   Vs1.3 -LSr -cd:20140622 -1pub:20140623(1.0/1)herber -lupd:20140806n
Sub VZellenSp(Optional ByVal FestAnzahl, Optional ByVal NurTrenn, Optional ByVal TrennZ, _
              Optional ByVal ZVbMod, Optional ByVal MxFmlBhdl)
    Const relHSpPos As Long = 2, VZvAlign As Long = 1, _
          altRufPgmF$ = "VZSpFestZ", altRufPgmT$ = "VZSpTrenn", dienstPgmL$ = _
          "LeerZeilEntf", patTrZ$ = "*-", vkElem$ = "&""?""&"
    Dim ect(4) As Long, hZv As Long, rat As Long, rct As Long, VbZAnz As Long, _
        kalkStat As XlCalculation, VZhAlign As XlHAlign, bix As XlBordersIndex, _
        cfc As Integer, defB As Integer, isFix As VbTriState, isFstCell As VbTriState, _
        vZW As VbMsgBoxResult, hasZVM As Boolean, isKill As Boolean, isPwoM As Boolean, _
        isSelect As Boolean, isSplit(2) As Boolean, adVBer As String, _
        fcGB(), fcXZ(), VZBrd(3) As Variant, aSh As Worksheet, cf As FormatCondition, _
        hBer As Range, lBer As Range, stZ As Range, vBer As Range, vX As Range, _
        vZ As Range, xV As Range, xZ As Range, zV As Range
    On Error GoTo fx: defB = 1: Set aSh = ActiveSheet
    With Application
        .ScreenUpdating = False: .EnableEvents = False
        kalkStat = .Calculation: .Calculation = xlCalculationManual
    End With
    hasZVM = Not IsMissing(ZVbMod): If hasZVM Then vZW = vbNo: isFstCell = -Abs(ZVbMod) Mod 3
    If Not IsMissing(FestAnzahl) Then
        If IsMissing(NurTrenn) And Not (IsEmpty(FestAnzahl) Or hasZVM) Then _
            isFstCell = MsgBox("Inhalte aller Zellen in der 1.Zelle verbinden?" & _
                        vbLf & "(N=nur 1.Wert, A=alle Werte bleiben erhalten)", vbQuestion + _
                        vbYesNoCancel + vbDefaultButton3, "Inhalte verbinden") Mod 3 - vbCancel
        isFix = 2 * CInt(IsArray(FestAnzahl))
        If CBool(isFix) Then
            ect(3) = LBound(FestAnzahl): ect(4) = UBound(FestAnzahl) + 1 - ect(3)
            ReDim Preserve FestAnzahl(ect(4) - 1)
            ect(3) = 0: ect(2) = FestAnzahl(ect(3))
        Else: ect(2) = FestAnzahl: isFix = -2 * ect(2) \ (ect(2) + 1)
        End If
    End If
    If Not IsMissing(NurTrenn) Then isSplit(0) = CBool(NurTrenn)
    If CBool(isFix) And isSplit(0) Then Set vBer = ActiveCell: On 1 - CInt(hasZVM) GoTo hi, ex
    If ActiveWindow.RangeSelection.Cells.Count >= minAnzAwZ Then GoTo sr
    On Error Resume Next
    If IsError(aSh.Names(naVBer)) Then
        On Error GoTo fx
sr:     Set vBer = ActiveWindow.RangeSelection: isSelect = True: GoTo wn
    Else: On Error GoTo fx: Set vBer = aSh.Range(naVBer)
wn:     If vBer.Cells.Count = 1 Or vBer.Columns.Count > 1 Then
            adVBer = vBer.AddressLocal(0, 0): If hasZVM Then Err.Raise xlErrNull
hi:         MsgBox "Dieses Programm gestaltet den ausgewählten Bereich " & _
            vbLf & "einer Spalte einer Liste auf dem aktuellen Blatt auf tabel-" & _
            vbLf & "lenübliche Form um; d.h., alle direkt aufeinanderfolgen-" & _
            vbLf & "den Zellen gleichen Inhalts werden miteinander dergestalt " & _
            vbLf & "verbunden, dass ihr jeweiliger Inhalt erhalten bleibt, wes-" & _
            vbLf & "halb danach noch Formelbezüge auf und sinnvolles Filtern " & _
            vbLf & "diese/r Zellen möglich ist (alternativ kann für den Bereich " & _
            vbLf & "auch der Name '" & naVBer & "' pro Blatt definiert werden). " & _
            vbLf & "Vorhandene Verbundzellen werden dabei wieder getrennt. " & _
            vbLf & "Soll nur Letzteres erfolgen, ist für den Aufruf des Programms " & _
            vbLf & "das alternative Rufprogramm '" & altRufPgmT & "' zu verwenden, " & _
            vbLf & "das ggf vorherige Bedingtformate zu rekonstruieren vermag, " & _
            vbLf & "sofern sie gleiche Geltungsbereiche haben. Mit Dienstpro-" & _
            vbLf & "gramm '" & dienstPgmL & "' können (ggf dadurch entstandene) " & _
            vbLf & "Leerzeilen entfernt werden. " & _
            vbLf & "Soll hingegen, unabhängig von ihrem Inhalt, eine gleichblei- " & _
            vbLf & "bende Anzahl von Zellen verbunden werden, ist das alterna-" & _
            vbLf & "tive Rufprogramm '" & altRufPgmF & "' zu benutzen. ", _
            IIf(CBool(isFix) And isSplit(0), vbInformation, vbExclamation), _
            "Pgm [" & IIf(CBool(isFix) And isSplit(0), "lauffähig ", "") & _
            "ab Vs12/2007] - Info:" & IIf(CBool(isFix) And isSplit(0), "", _
            " Nicht zulässig '" & IIf(isSelect, "", naVBer & "':='") & _
            adVBer & IIf(isSelect, "' ('" & naVBer & "'?)!", "'!")): GoTo ex
        End If
    End If
    rat = vBer.Rows.Count: cfc = vBer.FormatConditions.Count
    If isSplit(0) Then
        If CBool(cfc) Then
            ReDim fcXZ(0)
            For Each xZ In vBer
                If xZ.MergeCells Then
                    cfc = xZ.FormatConditions.Count
                    If CBool(cfc) Then
                        ReDim fcGB(cfc - 1): cfc = 0
                        For Each cf In xZ.FormatConditions
                            If CBool(hZv) Then
                                If cfc > UBound(fcXZ(hZv - 1)) Then GoTo nb
                                If Intersect(xZ, aSh.Range(fcXZ _
                                    (hZv - 1)(cfc))) Is Nothing Then GoTo nb
                                fcGB(cfc) = Union(aSh.Range(fcXZ(hZv - 1)(cfc)), _
                                            cf.AppliesTo, xZ.MergeArea).Address
                            Else
nb:                             fcGB(cfc) = Union(cf.AppliesTo, _
                                            xZ.MergeArea).Address
                            End If
                            cfc = cfc + 1
                        Next cf
                        ReDim Preserve fcXZ(hZv): fcXZ(hZv) = fcGB: hZv = hZv + 1
                    End If
                End If
            Next xZ
            cfc = -1: hZv = 0
        End If
    Else
        With aSh.UsedRange
            Set hBer = .Columns(.Columns.Count).Offset(0, relHSpPos)
        End With
        hZv = vBer.Rows(1).Row - hBer.Rows(1).Row
        Set hBer = aSh.Range(hBer.Cells(1 + hZv), hBer.Cells(hZv + rat))
        hZv = -1: vBer.Copy: hBer.PasteSpecial xlPasteFormats
    End If
    For Each xZ In vBer
        If xZ.MergeCells Then
            isSplit(1) = False
            If (vZW = 0 Or CBool(cfc)) And Not isSplit(0) Then
                On vZW \ vbNo GoTo vs
                defB = defB * Abs(Intersect(xZ, xZ.MergeArea.Cells(1)) Is Nothing)
                vZW = MsgBox("Die Auswahl enthält Verbundzellen, die getrennt werden, " & _
                      vbLf & "wobei eine evtl vormalige Bedingtformatierung ihrer Un-" & _
                      vbLf & "terzellen endgültig verloren wird! Falls die 1.Zelle des Ver-" &  _
_
                      vbLf & "bunds in der Aktionsspalte liegt, kann deren ggf abwei-" & _
                      vbLf & "chender Formatregel-Geltungsbereich zu Störungen füh-" & _
                      vbLf & "ren, die bei einer evtl späteren Trennung der Verbundzel-" & _
                      vbLf & "len den Verlust von Formatierungsregeln verursachen kön-" & _
                      vbLf & "nen. Rahmenlinien u. andere Formatierungen können ver-" & _
                      vbLf & "loren werden, wenn sie nicht denen des neuen Verbunds " & _
                      vbLf & "entsprechen bzw entweder der alte Verbund Grenzen des " & _
                      vbLf & "neuen überschreitet oder 2 alte an neuer Grenze direkt auf-" & _
                      vbLf & "einander folgen, wobei besonders neue Einzelzellen proble-" & _
                      vbLf & "matisch sind. Bei mehreren Trennungen im Neuverbund " & _
                      vbLf & "orientiert sich dessen Horizontalrahmenformatierung idR " & _
                      vbLf & "nur an der des zuletzt getrennten. Matrixformeln sollten in " & _
                      vbLf & "diesen Verbundzellen nicht enthalten sein!" & _
                      vbLf & vbLf & "Abbrechen oder fortsetzen und jede Verbundzelle " & _
                      "anzeigen " & vbLf & "(nur bei Existenz von Bedingt-Formaten! J/N)?", _
                      vbExclamation + vbYesNoCancel + Array(vbDefaultButton3, _
                      vbDefaultButton2, 0)(defB), "Warnung: Verbundzellentrennung")
                On vZW Mod vbYes GoTo vs, aw
                defB = 2
            End If
            If Not isSplit(0) Then
vs:             Set xV = xZ.MergeArea.Cells: VbZAnz = xV.Rows.Count
                For bix = xlEdgeLeft To xlEdgeRight
                    With Array(xV, xZ.Offset(-1, 0))(((bix - 6) Mod 3) Mod 2)
                        VZBrd(bix - xlEdgeLeft) = Array(.Borders(bix).Weight, _
                                .Borders(bix).LineStyle, .Borders(bix).Color)
                    End With
                Next bix
                VZhAlign = xV.HorizontalAlignment: isSplit(2) = True
            End If
            If isSplit(0) And VZvAlign > 0 Then Set xV = xZ.MergeArea.Cells
            With Application
                .DisplayAlerts = False: xZ.UnMerge: .DisplayAlerts = True
            End With
            If isSplit(0) And VZvAlign > 0 Then
                If xV.VerticalAlignment = xlTop Then
                    xV.VerticalAlignment = xlBottom
                ElseIf xV.VerticalAlignment = xlBottom Then
                    xV.VerticalAlignment = xlTop
                End If
                Set xV = Nothing
            End If
            isSplit(1) = isSplit(0)
        End If
        rct = rct + 1
        On 1 \ rct - CInt(isSplit(0)) * Abs(2 * CInt(isSplit(1)) - 1) GoTo nx, nx, nz, nz
        If CBool(isFix) Then
            hZv = CInt(ect(0) < ect(2) - 1)
            If isFix = vbUseDefault Then ect(3) = ect(3) - _
                CInt(hZv = 0): ect(2) = FestAnzahl(ect(3) Mod ect(4))
        Else: hZv = CInt(xZ = xZ.Offset(-1, 0))
        End If
        ect(0) = ect(0) - hZv: hZv = hZv Imp CInt(rct < rat)
        If hZv = 0 Or (CBool(ect(0)) And ect(0) = ect(1)) Then
            Set vZ = aSh.Range(hBer.Cells(rct + hZv - ect(0)), hBer.Cells(rct + hZv))
            If vZ.Rows.Count > 1 Then
                vZ.Merge
                If CBool(isFstCell) Then
                    Set vX = vBer.Cells(rct + hZv - ect(0))
                    If vX.HasArray And Not isPwoM Then
sc:                     If IsMissing(MxFmlBhdl) Then MxFmlBhdl = _
                            MsgBox("Zelle enthält Matrixformel!" & vbLf & _
                                   "Aktion ab hier generell [J] bzw im Einzel-" & vbLf & _
                                   "fall [N] aussetzen oder ganz beenden [A]?", _
                                   vbExclamation + vbYesNoCancel + vbDefaultButton2, _
                                   "Zelle " & vX.Address(0, 0))
                        Select Case MxFmlBhdl
                            Case vbYes:    isFstCell = vbFalse
                            Case vbNo:     isPwoM = True: isFstCell = Abs(isFstCell)
                            Case vbCancel: Err.Raise xlErrNA
                        End Select
                        If Not stZ Is Nothing Then Return
                    ElseIf isPwoM Then
                        isFstCell = Abs(isFstCell)
                    End If
                End If
                If CBool(isFstCell) Then
                    Set stZ = vBer.Cells(rct + hZv - ect(0))
                    For Each vX In aSh.Range(stZ, vBer.Cells(rct + hZv))
                        If vX.HasArray Then
                            If Not isPwoM Then GoSub sc
                            If (isKill Or Not stZ.HasArray) And Abs(isFstCell) = Abs(vbTrue)  _
Then
                                If lBer Is Nothing Then Set lBer = vX _
                                    Else Set lBer = Union(lBer, vX)
                            Else: Exit For
                            End If
                        ElseIf isKill And Abs(isFstCell) = Abs(vbTrue) Then
                        ElseIf stZ.HasFormula Or vX.HasFormula Then
                            If Not stZ.HasFormula Then stZ.Formula = "=" & _
                                Replace(Replace(vkElem, "&", "", 1, 2), "?", stZ.Value)
                            If isKill Then
                                If TrennZ <> "" Then
                                    If Not vX.HasFormula Then
                                        stZ.Formula = stZ.Formula & Replace(vkElem, "?", TrennZ) _
 & _
                                                      Replace(Replace(vkElem, "&", "", 1, 2), _
                                                      "?", vX.Value)
                                    Else: stZ.Formula = stZ.Formula & Replace(vkElem, "?", _
                                                        TrennZ) & Mid(vX.Formula, 2)
                                    End If
                                ElseIf Not vX.HasFormula Then
                                    stZ.Formula = stZ.Formula & "&" & Replace(Replace(vkElem, _
                                                  "&", "", 1, 2), "?", vX.Value)
                                Else: stZ.Formula = stZ.Formula & "&" & Mid(vX.Formula, 2)
                                End If
                            End If
                        ElseIf stZ.Formula = "" And vX.Formula <> "" Then
                            stZ.Formula = vX.Formula: isKill = True
                        ElseIf isKill Then
                            stZ.Value = stZ.Value & TrennZ & vX
                            If TrennZ = "" And IsNumeric(stZ.Value) Then stZ.Value = CDbl(stZ. _
Value)
                        End If
                        If isKill And lBer Is Nothing And stZ.Row <> vX.Row Then _
                            vX = Empty Else isKill = stZ.Formula <> ""
                    Next vX
                    If stZ.Formula = "" Then
                        stZ.Formula = Chr(160)                 'Anm: LöschSicherg f.1. _
BlockZeile
                    ElseIf isFstCell = vbUseDefault And TrennZ <> "" Then
                        While CBool(InStr(stZ.Formula, TrennZ & TrennZ))
                            stZ.Formula = Replace(stZ.Formula, TrennZ & TrennZ, TrennZ)
                        Wend
                        If RTrim(TrennZ) Like patTrZ Then
                            If stZ.HasFormula Then
                                stZ.Formula = "=""" & Right(TrennZ, 1 - CInt(Not TrennZ Like _
                                              patTrZ)) & """&" & Mid(stZ.Formula, 2)
                            Else: stZ = Right(TrennZ, 1 - CInt(Not TrennZ Like patTrZ)) & stZ
                            End If
                        End If
                    End If
                    isKill = False: Set stZ = Nothing
                    If Not lBer Is Nothing Then lBer.ClearContents: Set lBer = Nothing
                End If
            End If
            If isSplit(2) And Not (xV Is Nothing Or vZ Is Nothing) Then
                If Not Intersect(aSh.Range(xV.Rows(1).Row & ":" & _
                    xV.Rows(VbZAnz).Row), vZ) Is Nothing Then GoTo bz
                If VbZAnz = 1 Then
                    Set zV = vZ: Set vZ = aSh.Cells(xV.Row, hBer.Column)
bz:                 For bix = xlEdgeLeft To xlEdgeRight
                        If CBool((bix - xlEdgeLeft) Mod 3) Then
                            On Abs(vZ.Cells(1).Row = xV.Cells(1).Row Or _
                                vZ.Cells(vZ.Rows.Count).Row = xV.Cells(VbZAnz).Row) GoTo bt
                        Else
bt:                         vZ.Borders(bix).Weight = VZBrd(bix - xlEdgeLeft)(0)
                            vZ.Borders(bix).LineStyle = VZBrd(bix - xlEdgeLeft)(1)
                            vZ.Borders(bix).Color = VZBrd(bix - xlEdgeLeft)(2)
                        End If
                    Next bix
                    vZ.HorizontalAlignment = VZhAlign
                    If xV.Rows(VbZAnz).Row <= vZ.Rows(vZ.Rows.Count).Row Then _
                        isSplit(2) = False: VbZAnz = 0
                End If
            End If
            If Not zV Is Nothing Then Set vZ = zV: Set zV = Nothing
            If VZvAlign > 0 Then
                If vZ.VerticalAlignment = xlBottom Then vZ.VerticalAlignment = xlTop Else _
                    If vZ.VerticalAlignment = xlTop Then vZ.VerticalAlignment = xlBottom
            Else: If VZvAlign < 0 Then vZ.VerticalAlignment = VZvAlign
            End If
            ect(0) = 0: ect(1) = 0
        Else: ect(1) = ect(0): GoTo nx
nz:         If CBool(cfc) Then
                On Abs(hZv > UBound(fcXZ)) GoTo nx
                If Not IsEmpty(fcXZ(hZv)) Then
                    For cfc = 1 To xZ.FormatConditions.Count    'Anm: bei For Each ggf Xl- _
Absturz!
                        If cfc > xZ.FormatConditions.Count Then Exit For
                        Set cf = xZ.FormatConditions(cfc)
                        If cf.AppliesTo.Address <> fcXZ(hZv)(cfc - 1) Then _
                            cf.ModifyAppliesToRange aSh.Range(fcXZ(hZv)(cfc - 1))
                    Next cfc
                    hZv = hZv + 1
                End If
            End If
        End If
nx: Next xZ
    If Not isSplit(0) Then _
        vBer.FormatConditions.Delete: hBer.Copy: vBer.PasteSpecial xlPasteFormats
    vBer.Cells(rat + 1).Select: GoTo ex
aw: vBer.Cells(rct + 1).Select: GoTo ex
fx: If Err.Number = xlErrNull Then
        Debug.Print "Unzulässiger Aktionsbereich: " & adVBer
    ElseIf Err.Number <> xlErrNA Then
        If hasZVM Then
            Debug.Print "F" & Err.Number & ": " & Err.Description
        Else: MsgBox Err.Description, vbCritical, "Fehler " & Err.Number
        End If
    End If
ex: If Not hBer Is Nothing Then hBer.EntireColumn.Delete
    With Application
        .ScreenUpdating = True: .EnableEvents = True: .Calculation = kalkStat
    End With
    Set aSh = Nothing: Set cf = Nothing: Set hBer = Nothing: Set lBer = Nothing
    Set stZ = Nothing: Set vBer = Nothing: Set vX = Nothing: Set vZ = Nothing
    Set xV = Nothing: Set xZ = Nothing: Set zV = Nothing
End Sub



  

Betrifft: Dass er da steht, wo er steht, hatte 4 Gründe, ... von: Luc:-?
Geschrieben am: 12.10.2014 13:25:27

…Boris;
1. Ich musste/wollte hier einen zeitlichen „Fernlink“, also auf Zukünftiges, setzen, was hier so direkt ja nicht geht,
2. kann ich so sehen, wieviele sich das angesehen haben,
3. wollte ich dieses leider ziemlich tote TeilForum einer sinnvoll(er)en Nutzung zuführen und …
4. kennst du ja sicher PHs Meinung zu diesem Thema… ;-)
Luc :-?


  

Betrifft: ...und ein 5. ist, dass ich der Auffassung bin,... von: Luc:-?
Geschrieben am: 13.10.2014 20:18:11

…dass ein umfangreiches FertigTool wie dieses nicht unbedingt als LehrBsp geeignet ist und deshalb auch nicht in einem normalen Frage-Antwort-Forum erscheinen muss, Boris.
Für so etwas haben manche Foren Extra-Seiten (HWH hatte das mal vor, aber wieder aufgegeben). In Ol-Xl kann man aber ja auch das dortige CpForum so interpretieren… ;-)
Gruß, Luc :-?


  

Betrifft: AW: Hehe... von: Daniel
Geschrieben am: 14.10.2014 00:00:29

https://encrypted-tbn1.gstatic.com/images?q=tbn:ANd9GcQ92Wg759QgJRMZ_W4i4zqU85neJ9vdf7AnlSoHjym-YGp-UNOr
https://encrypted-tbn0.gstatic.com/images?q=tbn:ANd9GcTtwbQdYioWGQ5sm0ZnTwovMedzy-iIMXdJXvfs0NR_Sa3s47qQ


  

Betrifft: Dein Kommentar war absolut unnötig, weil ... von: Luc:-?
Geschrieben am: 16.10.2014 14:13:53

…es hier ja um etwas ganz Anderes, nämlich um die Nützlichkeit von VerbundZellen und wie man mit ihnen umgeht, ging, was du meinen Kommentaren (speziell auch unter dem Link!) leicht hättest entnehmen können, Daniel;
so wirkt dein BildKommentar mal wieder „wadenbeißerisch“…
Luc :-?


  

Betrifft: AW: Dein Kommentar war absolut unnötig, weil ... von: Daniel
Geschrieben am: 16.10.2014 16:52:05

wenn du Werbung für die Verwendung von Verbundenen Zellen machen willst, dann solltest du zeigen, dass man sie in VBA mit einfachen, leicht verständlichen Methoden (die auch ein Anfänger schnnell erlernt) be- und verarbeiten kann, anstatt auf solche Monstermakros zu verweisen.
Diese mögen zwar aus Sicht eines erfahren Programmierers toll sein, für alle anderen wirken sie eher abstossend.


  

Betrifft: Das ist ein FertigTool, das für den angegebenen... von: Luc:-?
Geschrieben am: 17.10.2014 20:21:31

…Zweck sofort eingesetzt wdn kann! Ob du das als abstoßend empfindest, Daniel,
ist dabei völlig irrelevant, denn hier kommt es auf bestmögliche Fktionalität an und nicht darauf, ob du bzw ein Anderer so etwas verstehen oder gar schreiben kann.
Das war auch per sé keine Werbung, sondern ein Hinweis auf SonderNutzen. Eine vollständige Beschreibung, was man dafür alles tun und beachten muss, wäre garantiert wesentlich kontraproduktiver.
Unter (VBA-)Zwergen kannst du dich ja gern als Riese fühlen, deshalb wird deine emotional-private SonderMeinung nicht richtiger. Lege Vglbares vor, dann kannst du auch ernsthaft mitdiskutieren (falls du das überhpt willst → ich denke ja, wohl eher nicht)! :->
Luc :-?


 

Beiträge aus den Excel-Beispielen zum Thema "Zellverbund aufheben (VBA)"