VBA Bereich löschen
22.09.2016 15:34:26
Berndt
ich möchte in mein Makro den Befehl einbinden, damit es mir einen von bis Bereich löscht.
von und bis wurde meines erachtens ausreichend definiert. Trotzdem weist der Code beim abspielen Fehler auf.
Vll. fällt jmd der Fehler auf.
Beim fett markierten Bereich stoppt das Makro.
https://www.herber.de/bbs/user/108350.xlsm
Private Sub CommandButton4_Click()
Dim a
Dim i As Long
Dim k As Long
Dim bis As Long
Dim ende As Long
Dim bisStart As Long
Dim von As Long
Dim Treffer As Range
Dim Start As Long
Dim go As Range
' Application.ScreenUpdating = False
Set go = Worksheets("Dashboard").Columns(2).Find("*Themenspeicher*", LookIn:=xlValues)
Start = go.Row + 1 'erste Zelle nach Themenspeicher in Sheet Dashboard
ende = Worksheets("dashboard").Range("B" & Rows.Count).End(xlUp).Row + 1
With Worksheets("Dashboard").Range("B" & go & ":G" & ende)
.Clear
.Borders(xlEdgeLeft).ThemeColor = 1
.Borders(xlEdgeTop).ThemeColor = 1
.Borders(xlEdgeBottom).ThemeColor = 1
.Borders(xlEdgeRight).ThemeColor = 1
.Borders(xlInsideVertical).ThemeColor = 1
.Borders(xlInsideHorizontal).ThemeColor = 1
.RowHeight = 12.75
End With
Set Treffer = Worksheets("Themenspeicher").Columns(2).Find("*Themenspeicher*", LookIn:= _
xlValues)
' Const von = 6
von = Treffer.Row + 1 'erste Zelle nach Themenspeicher in Sheet Themenspeicher
bis = Worksheets("Themenspeicher").Range("B" & Rows.Count).End(xlUp).Row + 1
a = Worksheets("Themenspeicher").Range("B" & von & ":E" & bis)
For i = 1 To UBound(a)
If a(i, 2) = "x" Then
bis = Sheets("Dashboard").Range("B2000").End(xlUp).Row + 1
If IsError(Application.Match(a(i, 1), Worksheets("Dashboard").Range("B1:B" & bis), 0)) _
Then
Sheets("Dashboard").Range("B" & bis) = a(i, 1)
Sheets("Dashboard").Range("E" & bis) = a(i, 4)
Sheets("Dashboard").Range("F" & bis) = a(i, 3)
If bisStart = 0 Then bisStart = bis
With Sheets("Dashboard").Range("F" & bis)
If .Offset(-1).Value .Value Then
With .Offset(, -4).Resize(, 6).Borders(xlEdgeTop)
.LineStyle = xlDot 'gepunktete Linie
.Weight = xlThin
End With
End If
End With
End If
End If
Next
If bisStart > 0 Then
With Sheets("Dashboard").Range("B" & bisStart & ":G" & bis)
With .Columns(1).Resize(, 3) 'Verbinden
.Merge True
.HorizontalAlignment = xlLeft 'linksbündig
.BorderAround xlContinuous 'Rahmen
.Font.Bold = False 'nicht fettgedruckt
.Font.Size = 9 'Schriftgröße 9
End With
With .Columns(4)
.HorizontalAlignment = xlLeft 'linksbündig
.BorderAround xlContinuous 'Rahmen
.Font.Size = 9 'Schriftgröße 9
End With
With .Columns(5).Resize(, 2) 'Verbinden
.Merge True
.HorizontalAlignment = xlCenter 'linksbündig
.BorderAround xlContinuous 'Rahmen
.Font.Size = 9 'Schriftgröße 9
End With
End With
End If
Application.ScreenUpdating = True
End Sub
Berndt