AW: VBA-erste Zelle nach Spaltekopf finden
22.09.2016 11:07:25
Berndt
so richtig funktioniert es noch nicht.
Habe das gleich mal versucht zu integrieren und habe einmal "von" (erste Zelle nach *Themenspeicher* in Sheet Dashboard) und "von1" (erste Zelle nach *Themenspeicher* in Sheet Themenspeicher) als variablen deiniert.
Der Fehler kommt nach von1 = Treffer1.Row + 1 'erste Zelle nach Themenspeicher in Sheet Dashboard: Laufzeitfehler '91: Objektvariable oder With-Blockvariable festgelegt
Private Sub CommandButton3_Click()
Dim a
Dim i As Long
Dim k As Long
Dim bis As Long
Dim bisStart As Long
Dim von As Long
Dim von1 As Long
Dim Treffer As Range
Dim Treffer1 As Range
Dim Ergebnis As Range
' Application.ScreenUpdating = False
Set Treffer1 = Worksheets("Dashboard").Columns(2).Find("*Themenspeicher*", LookIn:=xlValues)
Set Treffer = Worksheets("Themenspeicher").Columns(2).Find("*Themenspeicher*", LookIn:= _
xlValues)
von1 = Treffer1.Row + 1 'erste Zelle nach Themenspeicher in Sheet Dashboard
von = Treffer.Row + 1 'erste Zelle nach Themenspeicher in Sheet Themenspeicher
bis = Worksheets("Themenspeicher").Range("B" & Rows.Count).End(xlUp).Row + 1
a = Range("B" & von & ":E" & bis)
For i = 1 To UBound(a)
If a(i, 2) = "x" Then
bis = Sheets(a(i, 3)).Range("B2000").End(xlUp).Row + 1 ' 2000 reicht hier ja...
If IsError(Application.Match(a(i, 1), Worksheets(a(i, 3)).Range("B1:B" & bis), 0)) Then
Sheets(a(i, 3)).Range("B" & bis) = a(i, 1)
Sheets(a(i, 3)).Range("C" & bis) = a(i, 4)
Sheets(a(i, 3)).Range("B8:C8").Copy ' da ist das gleiche Format
Sheets(a(i, 3)).Range("B" & bis).Resize(, 2).PasteSpecial xlFormats
End If
End If
Next
With ThisWorkbook.Worksheets("Dashboard").Range("B" & bisStart & ":G" & bis)
.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
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