Trotzdem habe ich noch was für dich, ...
24.06.2014 00:15:57
Luc:-?
…Urmila,
und eventuelle andere Interessenten, aber ebfalls nur für eine Spalte (viell mache ich das irgendwann mal noch universeller?). Hierbei müssen alle gewünschten Formate bereits in der OriginalTab vorhanden sein, inkl vertikale/horizontale TextAusrichtung, denn sie wdn automatisch übernommen, ebenso wie das ZahlenFormat. Vertikale TextAusrichtung ist dabei besonders wichtig, weil die normalerweise auf unten (xlBottom) eingestellt ist, was zur Folge hätte, dass der Text in der VbZelle ebenfalls ganz unten erscheint, was iaR unüblich ist. Da das sicher häufig vergessen wdn würde, kann man eine entsprd Konst am PgmAnfang so einstellen, dass das korrigiert wird (s. Anmerk im Pgm).
Rem Vbindet Zellen gleichen Inhalts in d.m.d.Konst adVBer festgelegt Spalte;
' dabei bleibt Inhalt aller VbZellen unvändert erhalt, Formate wdn übnomm.
' 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! Diese Spalte wird letztendl wie-
' der entfernt. Außerdem darf d.letzte TabSpnZeile nicht d.letztmögl sein!
' Vs1.1 -LSr -cd:20140622 -1pub:29140623 herber -lupd:20140623t
Sub VbZellenSp()
Const adVBer$ = "B2:B16", relHSpPos As Integer = 2, vbVAlign As Long = 0
Rem Möglichkn f.Konst vbVAlign:
' 0 -> wie eingestellt, 1 -> Tausch xlBottom gg xlTop u.umgekehrt
' sonst immer nur lt Konst -> xlTop , xlCenter , xlBottom
Dim ect(1) As Long, hZv As Long, rct As Long, aSh As Worksheet, _
hBer As Range, vBer As Range, vZ As Range, xZ As Range
On Error GoTo fx
Set aSh = ActiveSheet: Set vBer = aSh.Range(adVBer)
If vBer.Columns.Count > 1 Then MsgBox "Nur 1 Spalte zulässig!", _
vbExclamation, "Bereich " & adVBer: GoTo ex
With aSh.UsedRange
Set hBer = .Columns(.Columns.Count).Offset(0, relHSpPos)
End With
hZv = vBer.Rows(1).Row - hBer.Rows(1).Row
For Each xZ In vBer.Resize(vBer.Rows.Count + 1, vBer.Columns.Count)
On 1 \ (rct + 1) GoTo nx
ect(0) = ect(0) - CInt(xZ = xZ.Offset(-1, 0))
If ect(0) = ect(1) Then
Set vZ = aSh.Range(hBer.Cells(rct - ect(0) + hZv), hBer.Cells(rct + hZv))
xZ.Offset(-1, 0).Copy: vZ.Cells(1).PasteSpecial xlPasteFormats: vZ.Merge
With vZ.Borders(xlEdgeTop)
.Weight = xZ.Offset(-ect(0) - 1, 0).Borders(xlEdgeTop).Weight
.LineStyle = xZ.Offset(-ect(0) - 1, 0).Borders(xlEdgeTop).LineStyle
.Color = xZ.Offset(-ect(0) - 1, 0).Borders(xlEdgeTop).Color
End With
With vZ.Borders(xlEdgeLeft)
.Weight = xZ.Offset(-1, 0).Borders(xlEdgeLeft).Weight
.LineStyle = xZ.Offset(-1, 0).Borders(xlEdgeLeft).LineStyle
.Color = xZ.Offset(-1, 0).Borders(xlEdgeLeft).Color
End With
With vZ.Borders(xlEdgeRight)
.Weight = xZ.Offset(-1, 0).Borders(xlEdgeRight).Weight
.LineStyle = xZ.Offset(-1, 0).Borders(xlEdgeRight).LineStyle
.Color = xZ.Offset(-1, 0).Borders(xlEdgeRight).Color
End With
With vZ.Borders(xlEdgeBottom)
.Weight = xZ.Offset(-1, 0).Borders(xlEdgeBottom).Weight
.LineStyle = xZ.Offset(-1, 0).Borders(xlEdgeBottom).LineStyle
.Color = xZ.Offset(-1, 0).Borders(xlEdgeBottom).Color
End With
If vbVAlign > 0 Then
If vZ.VerticalAlignment = xlBottom Then vZ.VerticalAlignment = xlTop _
Else vZ.VerticalAlignment = xlBottom
Else: If vbVAlign
Viel Erfolg!
Gruß Luc :-?