Bestehender Code mit Offset Zeilen 1-3 erweitern

Sub GitternetzlinienZeichnen() 'Gitternetzlinien zeichnen Dim rngBereich As Range, rngZeile As Range On Error Resume Next Set rngBereich = Intersect(Target, Range("A:K")) 'Bereich der Überwacht wird, ob was _ reingeschrieben wurde If Not rngBereich Is Nothing Then 'Spalten A bis K in geänderten Zeilen formatieren For Each rngZeile In rngBereich.Rows With Range(Cells(rngZeile.Row, 1), Cells(rngZeile.Row, 11)) 'Achtung die Hilfsspalte F _ _ _ ist versteckt If Application.WorksheetFunction.CountA(rngZeile) > 0 Then 'eine der Zellen A, B oder C in der geänderten Zeile enthält einen Wert With .Borders .LineStyle = xlContinuous .ColorIndex = 15 .Weight = xlThin End With Else 'wenn nichts im überwachten Bereich steht, dann wird folgendes ausgeführt .Borders.LineStyle = xlNone .ColorIndex = xlColorIndexNone Call GitternetzlinienTitelzeilen2 'siehe Modul "Gitternezlinien" End If End With Next End If End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Option Explicit ' IMMER zu empfehlen! Private Sub Worksheet_Change(ByVal Target As Range) 'Gitternetzlinien zeichnen Dim rngU As Range, rngB As Range, rngC As Range, rngZ As Range Set rngU = Range("A4:K9999") ' Wirkungsbereich Set rngB = Intersect(Target, rngU) If rngB Is Nothing Then Exit Sub For Each rngC In rngB.Columns(1) Set rngZ = Intersect(Rows(rngC.Row), rngU) With rngZ.Borders If Application.CountA(rngZ) > 0 Then .LineStyle = xlContinuous .ColorIndex = 15 .Weight = xlThin Else .LineStyle = xlNone .ColorIndex = xlColorIndexNone ' Call GitternetzlinienTitelzeilen2 'siehe Modul "Gitternezlinien" End If End With Next rngC End Sub

Private Sub Worksheet_Change(ByVal Target As Range) On Error Resume Next 'PaCo, Hyperlink öffen Const strHL As String = "http://paco.bas.roche.com/paco/packagingConfiguration/show/" If Target.Column = 9 Then If Target.Count = 1 Then If Target "" Then ActiveSheet.Hyperlinks.Add Target, strHL & Target End If End If End If 'Leerzeichen vor Text in Spalte E löschen Call LeerzeichenSpalteE_entfernen 'Gitternetzlinien zeichnen Dim rngBereich As Range, rngZeile As Range On Error Resume Next Set rngBereich = Intersect(Target, Range("A4:K10000")) 'Bereich der Überwacht wird, ob was _ reingeschrieben wurde If Not rngBereich Is Nothing Then 'Spalten A bis K in geänderten Zeilen formatieren For Each rngZeile In rngBereich.Rows With Range(Cells(rngZeile.Row, 1), Cells(rngZeile.Row, 11)) 'Achtung die Hilfsspalte F _ ist versteckt If Application.WorksheetFunction.CountA(rngZeile) > 0 Then 'eine der Zellen A, B oder C in der geänderten Zeile enthält einen Wert With .Borders .LineStyle = xlContinuous .ColorIndex = 15 .Weight = xlThin End With Else 'wenn nichts im überwachten Bereich steht, dann wird folgendes ausgeführt .Borders.LineStyle = xlNone .ColorIndex = xlColorIndexNone Call GitternetzlinienTitelzeilen2 'siehe Modul "Gitternezlinien" End If End With Next End If 'aktuelles Datum in Spalte A eintragen 'Das Script trägt ein Datum in Spalte A ein, egal was in eine Zelle eingetragen wird (ob Zahl _ oder Text!). Es löscht das Datum, wenn der Inhalt einer Zelle in Spalte C gelöscht wird. 'Um das von Spalte B (2) bis O (15) gültig zu machen: If Target.Count > 1 Then Exit Sub If Target.Column 5 Then Exit Sub '5 Spalten Application.EnableEvents = False If Target.Value "" Then Cells(Target.Row, 1) = Date Cells(Target.Row, 11) = VBA.Environ("Username") 'Windowsbenutzer Name in Spalte K, wenn _ Eintrag in Spalte B:J Else Cells(Target.Row, 1) = "" Cells(Target.Row, 11) = "" End If Application.EnableEvents = True 'Spalte E kopieren und in Spalte F einfügen If Target.Count > 1 Then Exit Sub If Target.Column 5 Then Exit Sub '5 Spalten Get_More_Speed3 Dim Cursorposition As Range Set Cursorposition = ActiveCell If Target.Value "" Then Cells(Target.Row, 6) = Range("E4:E1048576").Copy Range("F4:F1048576").PasteSpecial Paste:=xlValues Application.CutCopyMode = False Else Cells(Target.Row, 6) = "" End If Cursorposition.Parent.Select Cursorposition.Activate Get_More_Speed3 False ' Suchen und Hyperlink öffnen If Target.Cells.Count > 1 Then Exit Sub If Intersect(Range("E2"), Target) Is Nothing Then Exit Sub 'Suchfeld, Zelle für ACN-Nummer, _ hier ACN eingeben Dim i As Integer 'Zeile mit DB-Nr. On Error GoTo ErrorHandler i = Application.WorksheetFunction.Match(Range("E2"), Range("C:C"), 0) 'Suchfeld, Zelle und _ Suchspalte, in dieser Spalte wird die ACN-Nummer gesucht 'On Error GoTo 0 Cells(i, 9).EntireRow.Select 'Gesamte Zeile markieren Application.Wait (Now + TimeValue("0:00:02")) 'Wartezeit Cells(i, 9).Hyperlinks(1).Follow NewWindow:=False, AddHistory:=True 'Spalte in der die PaCo- _ Id und Link steht, 9 Spalten von Links gezählt (Spalte F ist versteckt), in diesem Fall Spalte H, Hyperlink wird geöffnet, aktiviert Exit Sub ErrorHandler: MsgBox "Datensatz oder Hyperlink nicht vorhanden" Range("E2").Select End Sub

Hi Peter,
"leider funktioniert diese Variante nicht": Mmmmh. Möchtest du uns nicht mitteilen, was genau da nicht funktioniert?
Meldet der Compiler einen Fehler? Gibt es Laufzeitfehler? Welche Fehlernummer, welcher Fehlerhinweis?
In welcher Codezeile tritt der Fehler auf?
Solche Angaben sind für Fehlersuche und sinnvolle Antworten recht nützlich...
(Dazu steht auch etwas in den Forums-FAQ.)
Eine Detailfrage zum Code: Im Abschnitt "Spalte E kopieren und in Spalte F einfügen" gibt es die Zeile
Cells(Target.Row, 6) = Range("E4:E1048576").Copy
Was soll das bedeuten? Da wird ein WAHR als Returnwert des Copy in eine Zelle in Spalte 6 geschrieben.
Vom direkt nachfolgenden PasteSpecial wird der Wert gleich überschrieben.
Die Copy-Zeile ist in dieser Form nicht sinnvoll und dürfte kaum so gewollt sein.
Was soll mit Cells(Target.Row, 6) geschehen?
Im selben Abschnitt steht "Cursorposition.Parent.Select". Hat das einen Sinn?
Das Tabellenblatt ist doch schon das aktive.
Hier eine abgewandelte Fassung des Codes, die bei mir läuft:


Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Const strHL As String = "http://paco.bas.roche.com/paco/packagingConfiguration/show/"
Dim rngBereich As Range, rngZeile As Range
Dim rngU As Range, rngB As Range, rngC As Range, rngZ As Range
Dim Cursorposition As Range
Dim i As Integer 'Zeile mit DB-Nr.
'On Error Resume Next ' ###
'PaCo, Hyperlink öffen
If Target.Count = 1 And Target.Column = 9 Then
If Target  "" Then ActiveSheet.Hyperlinks.Add Target, strHL & Target
End If
'Leerzeichen vor Text in Spalte E löschen
'Call LeerzeichenSpalteE_entfernen '###
'Gitternetzlinien zeichnen
'   On Error Resume Next '###
Set rngU = Range("A4:K10000")               ' Wirkungsbereich
Set rngB = Intersect(Target, rngU)
If Not rngB Is Nothing Then
For Each rngC In rngB.Columns(1)
Set rngZ = Intersect(Rows(rngC.Row), rngU)
With rngZ.Borders
If Application.CountA(rngZ) > 0 Then
.LineStyle = xlContinuous
.ColorIndex = 15
.Weight = xlThin
Else
.LineStyle = xlNone
.ColorIndex = xlColorIndexNone
'           Call GitternetzlinienTitelzeilen2 'siehe Modul "Gitternezlinien" ' ###
End If
End With
Next rngC
End If
'aktuelles Datum in Spalte A eintragen
'Das Script trägt ein Datum in Spalte A ein, egal was in eine Zelle eingetragen wird
' (ob Zahl oder Text!). Es löscht das Datum, wenn der Inhalt einer Zelle in Spalte C
' gelöscht wird. Um das von Spalte B (2) bis O (15) gültig zu machen:
If Target.Count > 1 Then Exit Sub
If Target.Column  5 Then Exit Sub '5 Spalten
Application.EnableEvents = False
If Target.Value  "" Then
Cells(Target.Row, 1) = Date
'Windowsbenutzer Name in Spalte K, wenn Eintrag in Spalte B:J
Cells(Target.Row, 11) = VBA.Environ("Username")
Else
Cells(Target.Row, 1) = ""
Cells(Target.Row, 11) = ""
End If
Application.EnableEvents = True
'Spalte E kopieren und in Spalte F einfügen
If Target.Count > 1 Then Exit Sub
If Target.Column  5 Then Exit Sub  '5 Spalten
'    Get_More_Speed3 ' ###
Set Cursorposition = ActiveCell
Application.EnableEvents = False
If Target.Value  "" Then
'     Cells(Target.Row, 6) = Range("E4:E1048576").Copy         ' unklar ?
Range("E4:E1048576").Copy                                ' richtig ?
Range("F4").PasteSpecial Paste:=xlValues
Application.CutCopyMode = False
Else
Cells(Target.Row, 6) = ""
End If
Application.EnableEvents = True
Cursorposition.Parent.Select                                ' Wozu das denn?
Cursorposition.Activate
'    Get_More_Speed3 False ' ###
'  Suchen und Hyperlink öffnen
'  If Target.Cells.Count > 1 Then Exit Sub ' ### ist oben schon erledigt
'Suchfeld, Zelle für ACN-Nummer, hier ACN eingeben
If Intersect(Range("E2"), Target) Is Nothing Then Exit Sub
'  On Error GoTo ErrorHandler ' ###
'Suchfeld, Zelle und Suchspalte, in dieser Spalte wird die ACN-Nummer gesucht
i = Application.Match(Range("E2"), Columns(3), 0)
If IsError(i) Then
MsgBox "Datensatz oder Hyperlink nicht vorhanden"
Range("E2").Select
Else
'     Cells(i, 9).EntireRow.Select           'Gesamte Zeile markieren
Rows(i).Select                         'Gesamte Zeile markieren      ' wozu eigentlich?
Application.Wait (Now + TimeValue("0:00:02"))   'Wartezeit
'Spalte in der die PaCo-Id und Link steht, 9 Spalten von Links gezählt
'(Spalte F ist versteckt), in diesem Fall Spalte H, Hyperlink wird geöffnet, aktiviert
If Cells(i, 9).Hyperlinks.Count > 0 Then _
Cells(i, 9).Hyperlinks(1).Follow NewWindow:=False, AddHistory:=True
End If
'  On Error GoTo 0
'ErrorHandler: ' ###
End Sub

Gefährlich finde ich die inflationäre Verwendung des "On Error Goto" bzw. "On Error Resume Next".
Rückmeldung wäre nett! - Grüße aus Kamp-Lintfort von Erich

Hallo Erich
Danke für Deinen Input, anbei mal meine Erklärungen zu meinem Code und Deinen Fragen.
Deinen Code werde ich zu einem späteren Zeitpunkt testen, melde mich dann wieder.
1. Es gibt keine Fehlermeldung, die Suchfunktion funktioniert einfach nicht mehr. In der Spalte C stehen Datensatznummern einer Webdatenbank. In der Zelle E2 ist das Suchfeld, in dem kann die gesuchte Datensatznummer eingegeben werden, diese wird in der Spalte C abgefragt, wenn diese gefunden wird, wird via Hyperlink der entsprechende Datensatz der Webdatenbank automatisch gesucht, gefunden und geöffnet und kann eingesehen werden.
2. Spalte E ab E4 kopieren und in Spalte F, ab F4 einfügen: In der Spalte E stehen mehrere Informationen, die in der benutzerdefinierten Symbolleiste, die ich erstell habe, abgefragt werden können. Jedoch kann immer nur ein Filterkriterium abgefragt werden, jedoch mehrere sind nötig, so habe ich mit der Spalte F eine Hilfsspalte erstellt, in der die gleichen Informationen stehen wie in E, so können zwei Filterkriterien eingestellt werden, 1x in Spalte E und das 2x in Spalte F. Die Idee ist, wenn was in Spalte E geändert wurde, dann wird einfach die ganze Spalte E kopiert und in F reinkopiert und die vorhergehenden Werte überschrieben.
3. Set Cursorposition = ActiveCell und Cursorposition.Parent.Select und Cursorposition.Activate ' Wozu das denn?: Wie oben beschrieben, wird die ganze Spalte E bei einer Eingabe, oder Datenänderung kopiert. Wenn eine Eingabe in der Spalte E vorgenommen wird, wird die Curserposition gespeichert und nach dem Kopieren und Einfügen in Spalte F, wieder aktiviert, damit der Curser wieder an der gleichen Position ist wie zuvor.
4. Rows(i).Select 'Gesamte Zeile markiere' wozu eigentlich?: Damit der Anwender sieht, auf welchen Datensatz seine Sucheingabe in Zelle E2 gesprungen ist.
Gruss,
Peter

Beliebteste Forumthreads (12 Monate)

Bestehender Code mit Offset Zeilen 1-3 erweitern

8 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

8
Beiträge zum Forumthread

Beiträge zu diesem Forumthread