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 .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 ElementtDefault: 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.oP20): 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) 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) 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 0 Then
If vZ.VerticalAlignment = xlBottom Then vZ.VerticalAlignment = xlTop Else _
If vZ.VerticalAlignment = xlTop Then vZ.VerticalAlignment = xlBottom
Else: If VZvAlign 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
