AW: Excel A-Z-Liste mit VBA makro
19.07.2016 09:15:48
Mullit
Hallo,
ja stimmt schon, fiel mir auch noch gestern auf, da könnts mit den dyn. Tabs schwierig werden, also machen wir uns doch nochmal ans proggen, an Stelle vieler Buttons wäre da ein Doppelclick auf Deine Buchstaben-Verbundzellen-Header vielleicht noch besser:
Option Explicit
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim objCell As Range, objRange As Range
Set objRange = Cells(2, 1).Resize(Cells(Rows.Count, 1).End(xlUp).Row, 1)
For Each objCell In objRange
With objCell
If .MergeCells Then
If Target.Cells(1, 1).Value = .Value Then
If .Interior.Color = RGB(189, 215, 238) Then
Cancel = True
Call prcAddNewRow(probjRange:=objRange, _
pvstrChar:=Chr$(Asc(.Value) + 1))
Set objCell = Nothing
Exit For
End If
End If
End If
End With
Next
Set objRange = Nothing
End Sub
Private Sub prcAddNewRow(ByRef probjRange As Range, ByVal pvstrChar As String)
Dim objCell As Range
Dim vntReturn As Variant
vntReturn = Application.Match(pvstrChar, probjRange, 0)
If Not IsError(vntReturn) Then
Application.ScreenUpdating = False
If Rows(vntReturn).Insert(Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove) Then
With Cells(vntReturn, 1)
.Resize(1, 26).MergeCells = True
With .MergeArea
Call prcSetBorderStyle(.Borders(xlEdgeLeft), .Borders(xlEdgeTop), _
.Borders(xlEdgeBottom), .Borders(xlEdgeRight))
End With
Call prcSetBorderStyle(Cells(vntReturn + 1, 1).MergeArea.Borders(xlEdgeTop))
End With
Else
Call MsgBox("Die Zeile konnte nicht eingefügt werden...", vbExclamation)
End If
Application.ScreenUpdating = True
ElseIf pvstrChar = "[" Then
vntReturn = Application.Match("Z", probjRange, 0)
If Not IsError(vntReturn) Then
Application.ScreenUpdating = False
For Each objCell In Cells(vntReturn + 2, 1).Resize(Rows.Count - (vntReturn + 2), 1)
With objCell
If .MergeArea.Cells.Count > 26 Then
If Rows(.Row).Insert(Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove) Then
With Cells(.Row - 1, 1)
.Resize(1, 26).MergeCells = True
With .MergeArea
Call prcSetBorderStyle(.Borders(xlEdgeLeft), .Borders(xlEdgeTop), _
.Borders(xlEdgeBottom), .Borders(xlEdgeRight))
End With
End With
Call prcSetBorderStyle(Cells(.Row, 1).MergeArea.Borders(xlEdgeTop))
Else
Call MsgBox("Die Zeile konnte nicht eingefügt werden...", vbExclamation)
End If
Exit For
End If
End With
Next
Application.ScreenUpdating = True
If objCell Is Nothing Then
Call MsgBox("Abschließender Verbund-Bereich nach 'Z' muß mehrere Zeilen umfassen...", vbExclamation)
Else
Set objCell = Nothing
End If
Else
Call MsgBox("Es konnte kein entsprechender Buchstabe gefunden werden...", vbExclamation)
End If
Else
Call MsgBox("Es konnte kein entsprechender Buchstabe gefunden werden...", vbExclamation)
End If
End Sub
Private Sub prcSetBorderStyle(ParamArray ppavntBorders() As Variant)
Dim ialngIndex As Long
For ialngIndex = 0 To Ubound(ppavntBorders)
With ppavntBorders(ialngIndex)
.LineStyle = xlContinuous
.Color = RGB(189, 215, 238)
.Weight = xlThin
End With
Next
End Sub
VBA/HTML - CodeConverter für Office-Foren
AddIn für Excel/Word 2000-2010 - komplett in VBA geschrieben von Lukas Mosimann
Projektbetreuung durch mumpel
Code erstellt und getestet in Office 14
Als kleine Anmerkung noch: man sollte es mit Verbundzellen möglichst nicht übertreiben...
Gruß, Mullit