Adressierung Range/Cells Bereich+Rahmen
19.12.2021 13:28:59
Romy
Ich hab mir über die Suchfunktion und Google den unten aufgeführten Code zusammen gebastelt. Nun wollte ich gerne Code einbauen, welcher mir einen Rahmen um bestimmte Bereiche zieht (siehe fettgedruckten Code). Jedoch wirft mir der Debugger immer einen Fehler (Laufzeit 1004) aus und ich komme von alleine nicht mehr weiter. Bestimmt hab ich irgentetwas nicht richtig deklariert. Könnt ihr bitte mal prüfen und mir weiterhelfen. Danke schonmal im Voraus.
Option Explicit
Dim Suchergebnis As Range
Dim lngZielZeile As Long, lngZaehler As Long
Dim SuchWert As String, SuchSpalte As String
Dim firstAddress
Dim OriginalSpalte As Integer, KopieSpalte As Integer
Dim AktuellesDatum As Date, SuchDatum As Date
Dim Formel1 As String, SuchFormel As String
Dim BlattNameKopie As String, BlattNameOriginal As String
Sub Kopieren()
BlattNameKopie = "Auflistung"
BlattNameOriginal = "Projekt"
SuchSpalte = "Projektl[Hilfsspalte]"
SuchWert = "Ja"
Formel1 = "=IF(AND([@[Ort]]=" & SuchFormel & ",[@Beginn]TODAY(),[@Ende]="""")),""Ja"",""Nein"")"
Call FormelEintragen
With Sheets(BlattNameOriginal)
Set Suchergebnis = .Range(SuchSpalte).Find(SuchWert, LookIn:=xlValues, LookAt:=xlWhole)
If Not Suchergebnis Is Nothing Then
firstAddress = Suchergebnis.Address
Do
For OriginalSpalte = 10 To 10 'Angabe der zu kopierenden Spalten je gefundener Zelle
Sheets(BlattNameKopie).Cells(lngZielZeile, KopieSpalte) = .Cells(Suchergebnis.Row, OriginalSpalte)
With Sheets(BlattNameKopie).Range(.Cells(lngZielZeile, KopieSpalte), .Cells(lngZielZeile + 5, KopieSpalte + 8)).Selection
.Borders(xlDiagonalDown).LineStyle = xlNone
.Borders(xlDiagonalUp).LineStyle = xlNone
With .Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
End With
.Borders(xlInsideVertical).LineStyle = xlNone
.Borders(xlInsideHorizontal).LineStyle = xlNone
End With
Next
lngZielZeile = lngZielZeile + 1 'Anzahl der Zeilen die zwischen den kopierten Daten liegen
lngZaehler = lngZaehler + 1
For OriginalSpalte = 2 To 2 'Angabe der zu kopierenden Spalten je gefundener Zelle
Sheets(BlattNameKopie).Cells(lngZielZeile, KopieSpalte) = .Cells(Suchergebnis.Row, OriginalSpalte)
Next
lngZielZeile = lngZielZeile + 1 'Anzahl der Zeilen die zwischen den kopierten Daten liegen
lngZaehler = lngZaehler + 1
For OriginalSpalte = 1 To 1 'Angabe der zu kopierenden Spalten je gefundener Zelle
Sheets(BlattNameKopie).Cells(lngZielZeile, KopieSpalte) = .Cells(Suchergebnis.Row, OriginalSpalte)
Next
lngZielZeile = lngZielZeile + 2 'Anzahl der Zeilen die zwischen den kopierten Daten liegen
lngZaehler = lngZaehler + 1
Set Suchergebnis = .Range(SuchSpalte).FindNext(Suchergebnis)
Loop While Not Suchergebnis Is Nothing And Suchergebnis.Address firstAddress
MsgBox "Es wurden zum Suchwert " & SuchWert & vbCrLf & lngZaehler & " Datensätze kopiert"
Else
MsgBox "Kein Eintrag"
End If
End With
End Sub
Sub Test()
SuchFormel = """NB"""
lngZielZeile = 15 'Startzeile zum Einfügen der kopierten Daten
lngZaehler = 0
KopieSpalte = 1 'Spalte in welcher die kopierten Daten eingefügt werden sollen
Call Kopieren
Call FormelLoeschen
SuchFormel = """RBL"""
lngZielZeile = 15 'Startzeile zum Einfügen der kopierten Daten
lngZaehler = 0
KopieSpalte = 9 'Spalte in welcher die kopierten Daten eingefügt werden sollen
Call Kopieren
Call FormelLoeschen
End Sub
Sub FormelEintragen()
Range(SuchSpalte).FormulaR1C1 = Formel1
End Sub
Sub FormelLoeschen()
Range(SuchSpalte).ClearContents
End Sub