Bestehender Code mit Offset Zeilen 1-3 erweitern

Forumthread: Bestehender Code mit Offset Zeilen 1-3 erweitern

20.03.2015 08:52:14

Peter

Hallo Zusammen
Habe unten stehenden Code (Internet), mit folgender Funktion:
Wenn in Spalten A:C was reingeschrieben wird, werden die Gitternetzlinien A:K gezeichnet, wird in A:C gelöscht, verschinden die Gitternetzlinien etc.
Jedoch habe ich in den ersten drei Zeilen eine Suchfunktion in der eine Eingabe erfolgt. D.h. ich benötige einen Offset, so dass die Funktion Gitternetzlinien zeichnen, löschen erst ab Zeile 4 funktionieren.
Ich habe bereits versucht in der Codezeile
Set rngBereich = Intersect(Target, Range("A:K"))
folgendes Versucht:
Set rngBereich = Intersect(Target, Range("A4:K10000"))
hat jedoch leider nicht funktioniert.
Hat jemand eine Idee einen Offset Zeile 1-3 einzufügen?

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

Vielen Dank
Mit freundlichen Grüssen
Peter

8
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

AW: Bestehender Code mit Offset Zeilen 1-3 erweitern

20.03.2015 09:11:25

Rudi
Offset Zeilen 1-3 erweitern, wie weiter?

24.03.2015 14:20:19

Scheuzger
anderer Ansatz

24.03.2015 16:46:27

Erich
AW: anderer Ansatz

25.03.2015 14:18:26

Peter
AW: anderer Ansatz

25.03.2015 17:46:37

Erich
AW: anderer Ansatz

26.03.2015 08:54:08

Peter
Klärungen

26.03.2015 09:32:04

Erich
AW: Klärungen

26.03.2015 13:47:46

Peter

AW: Bestehender Code mit Offset Zeilen 1-3 erweitern

20.03.2015 09:11:25

Rudi

Hallo,
Set rngBereich = Intersect(Target, Range("A4:K10000"))
sollte funktionieren.
Wie übergibst du Target an die Prozedur?
Gruß
Rudi

Offset Zeilen 1-3 erweitern, wie weiter?

24.03.2015 14:20:19

Scheuzger

Hallo Rudi,
Leider funktioniert "Set rngBereich = Intersect(Target, Range("A4:K10000"))" nicht, dass hatte ich schon ausprobiert.
Wie das Target an die Prozedur weiter gegeben wird weiss ich nicht, funktioniert daher der Offset, resp. die Bereichseingrenzung Range("A4:K10000"))" nicht.
Wie weiter, wie könnte ich die den Offset umsetzen und was ist mit dieser Uebergabe des Target an die Prozedur?
Danke für Deine, jede Hilfe.
Mit freundlichem Gruss
Peter

anderer Ansatz

24.03.2015 16:46:27

Erich

Hi Peter,
probier mal (Code im Code des entsdp. Tabellenblatts):


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

Rückmeldung wäre nett! - Grüße aus Kamp-Lintfort von Erich

AW: anderer Ansatz

25.03.2015 14:18:26

Peter

Hallo Erich
Danke für Deine Antwort, leider funktioniert diese Variante nicht. Die eigentliche Prozedur die ich verwende ist umfangreicher und ich vermute, dass da sich was "beisst". Anbei die komplette Prozedur:
Option Explicit

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

Vielleicht hast Du Zeit und kannst damit was anfangen.
Vielen Dank
Gruss,
Peter

AW: anderer Ansatz

25.03.2015 17:46:37

Erich

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

AW: anderer Ansatz

26.03.2015 08:54:08

Peter

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

Klärungen

26.03.2015 09:32:04

Erich

Hi Peter,
danke für die Erläuterungen! Bei einigen Fragen/Antworten scheint aber noch Klärungsbedarf zu sein. :-)
zu 1.:
Dass die Suche (letzter Abschnitt der Prozedur) nicht lief, ist klar. Mit
If rngB Is Nothing Then Exit Sub
wurde die Prozedur ja verlassen, bevor der Code erreicht wurde.
Dieses "Exit Sub" ist natürlich Unfug, wenn danach evtl. noch Code abzuarbeiten ist.
In der neuen Version ist das natürlich geändert.
zu 2.:
Der Sinn des Abschnitts "Spalte E kopieren und in Spalte F einfügen" war mir im Prinzip schon klar.
Unverständlich fand und finde ich nur die Zeile
Cells(Target.Row, 6) = Range("E4:E1048576").Copy
Was soll da in Cells(Target.Row, 6) geschrieben werden?
Range("E4:E1048576").Copy und die anderen Zeilen verstehe ich schon. :-)
zu 3.:
Set Cursorposition = ActiveCell und Cursorposition.Parent.Select und Cursorposition.Activate ' Wozu das denn?
hatte ich gar nicht geschrieben. ' Wozu das denn? bezog sich nur auf die einzelne Zeile
"Cursorposition.Parent.Select". Dazu hatte ich geschrieben:
Im selben Abschnitt steht "Cursorposition.Parent.Select". Hat das einen Sinn?
Das Tabellenblatt ist doch schon das aktive.
Der Sinn der Zeilen "Set Cursorposition = ActiveCell" und "Cursorposition.Activate" war und ist mir klar.
Rückmeldung wäre nett! - Grüße aus Kamp-Lintfort von Erich

AW: Klärungen

26.03.2015 13:47:46

Peter

Sali Erich
Danke für Deine Anwort.
zu 1.: Ich dachte, dass ich das "Then Exit Sub" schon rausgenommen habe, bin mir jetzt aber nicht mehr sicher. Ich werde das Ganze noch testen, hab aber und leider aktuell keine Zeit dafür. Sobald ich es getestet habe melde ich mich entsprechend noch einmal und gebe eine Rückmeldung.
zu 2. Es geht einfach darum, wie schon beschrieben, wenn es eine Aenderung in der Spalte E gibt, dann wird immer die ganze Spalte E kopiert und in F rein kopiert. Es hat funktioniert, den Code habe mir irgend wo her aus einem anderen Zusammenhang kopiert. So geht das immer bei mir, ich Schustere mir die Prozedur zusammen und suche Hilfe wenn es nicht geht, jedoch frei programmiern ist bei mir leider nicht drin. Wahrscheinlich ist "Cells(Target.Roc,6) = Range("E4:E1048576").Copy" überflüssig, werde ich testen.
zu 3. Ah ok, auch hier wie bei zu 2 beschrieben, Codeschnipsel von irgend wo her, somit wieder was dazu gelernt :-)
Ich melde mich sobald ich mehr Zeit dafür habe.
Danke Dir für deinen Input und Zeit, sehr nett und äußerst willkommen :-)
Gruss,
Peter

Beliebteste Forumthreads (12 Monate)

Bestehender Code mit Offset Zeilen 1-3 erweitern

Forumthread: Bestehender Code mit Offset Zeilen 1-3 erweitern

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

VBA Beispiele zu diesem und ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

8
Beiträge zum Forumthread

Beiträge zu diesem Forumthread