Anzeige
Archiv - Navigation
1860to1864
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Adressierung Range/Cells Bereich+Rahmen

Adressierung Range/Cells Bereich+Rahmen
19.12.2021 13:28:59
Romy
Hallo liebe Community,
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

6
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Adressierung Range/Cells Bereich+Rahmen
19.12.2021 14:00:49
GerdL
Moin Romy,
gib Kopiespalte einen Wert oder lässt du immer Test zuerst laufen?
Gruß Gerd
AW: Adressierung Range/Cells Bereich+Rahmen
19.12.2021 14:13:36
Romy
Hallo Gerd,
die Sub Test läuft immer als erstes.
AW: Adressierung Range/Cells Bereich+Rahmen
19.12.2021 14:37:27
Beverly
Hi Romy,
in der Zeile

With Sheets(BlattNameKopie).Range(.Cells(lngZielZeile, KopieSpalte), .Cells(lngZielZeile + 5, KopieSpalte + 8)).Selection
beziehen sich die Range- und Cells-Bezüge auf das Tabellenblatt "Projekt", weil du dich bereits in der With-Anweisung With Sheets(BlattNameOriginal) befindest. Die o.g. With-Anweisung soll sich aber offensichtlich auf das Tabellenblatt "Auflistung" beziehen. Du musst also an allen Zellbezügen noch Sheets(BlattNameKopie) davor schreiben. Außerdem kannst du jegliches Selection weglassen:

With Sheets(BlattNameKopie).Range(Sheets(BlattNameKopie).Cells(lngZielZeile, KopieSpalte), _
Sheets(BlattNameKopie).Cells(lngZielZeile + 5, KopieSpalte + 8))
.Borders(xlDiagonalDown).LineStyle = xlNone
.Borders(xlDiagonalUp).LineStyle = xlNone
With .Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
End With
With .Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
End With
With .Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
End With
With .Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
End With
.Borders(xlInsideVertical).LineStyle = xlNone
.Borders(xlInsideHorizontal).LineStyle = xlNone
End With
Bis später
Karin

Anzeige
Problem gelöst
19.12.2021 15:08:45
Romy
Danke Karin, deine Erklärung hat mir weitergeholfen meinen Fehler zu verstehen und meinen Code anzupassen. Die Selektion Methode stand noch im Code, da ich mein Vorhaben zuerst mit dem Recorder aufgezeichnet hatte um zu sehen, welchen ich Code benötigen würde.

With Sheets(BlattNameKopie).Range(Sheets(BlattNameKopie).Cells(lngZielZeile, KopieSpalte), Sheets(BlattNameKopie).Cells(lngZielZeile + 2, KopieSpalte + 8))
.Borders(xlEdgeLeft).LineStyle = xlContinuous
.Borders(xlEdgeTop).LineStyle = xlContinuous
.Borders(xlEdgeBottom).LineStyle = xlContinuous
.Borders(xlEdgeRight).LineStyle = xlContinuous
End With

Anzeige
AW: Adressierung Range/Cells Bereich+Rahmen
19.12.2021 14:41:13
Daniel
Hi

With Sheets(BlattNameKopie).Range(.Cells(lngZielZeile, KopieSpalte), .Cells(lngZielZeile + 5, KopieSpalte + 8)).Selection
Hier sind zwei Dinge falsch:
1. wird in With-Definition nicht selektiert. In der With-Definition gibt man nur das (Teil)-Objekt an, welches in Folge dann eingesetzt wird, wenn ein Ausdruck mit dem Punkt beginnt.
2. definiert man einen Zellbereich über Range(Cells(), Cells()), so müssen die beiden Cells auf dem selben Tabellenblatt liegen wie die Range, die sie definieren sollen.
Du hast aber hier zwei verschiedene Blätter im Einsatz, vor Range steht Sheets(BlattNameKopie) und vor den beiden Cells der Punkt, dh hier wird das Blatt der zuletzgemachten und an dieser Stelle immer noch gültigen With-Definition eingesetzt, nämlich Sheets(BlattNameOriginal)
Du musst hier an allen drei Stellen das selbe Tabellenblatt einsetzen.
Ich empfehle, statt Range(Cells(), Cells()) den Zellbereich über Cells(). Resize() zu definieren, vor allem dann, wenn man wie es bei dir der Fall ist, die Größe des Zellbereich kennt.
Gruß Daniel
Anzeige
Problem gelöst
19.12.2021 15:09:53
Romy
Hallo Daniel und Danke für den Lösungsvorschlag.

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige