Problem bei worksheet_Change

Question

Hallo,

ich habe ein Makro mit dem ich aus einer Liste bestimmte Daten filtere und diese auf ein Hilfsblatt kopiere, als normales Makro funktioniert es

Sub Makro1()
wert = Left(ActiveCell.Value, 3)
Sheets("02_Objekt").Select
Selection.AutoFilter Field:=4, Criteria1:="=*" & wert & "*", Operator:=xlAnd
Range("J1:J100").Select
Selection.Copy
Sheets("Hilfsblatt").Select
Range("J1").Select
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Sheets("02_Objekt").Select
Selection.AutoFilter Field:=4
Sheets("Arbeitsblatt").Select
Range("G" & Range("F" & Rows.Count).End(xlUp).Row).Select
End Sub

Mit der Funktion worksheet_Change habe ich Probleme, ich bekomme die Funktion zwar gestartet, aber dann kommt eine Fehlermeldung

Private Sub worksheet_Change(ByVal Target As Range)
Application.EnableEvents = False
If Not Application.Intersect(Target, Range("F6:F1000")) Is Nothing Then
wert = Left(ActiveCell.Value, 3)
Sheets("02_Objekt").Select
Selection.AutoFilter Field:=4, Criteria1:="=*" & wert & "*", Operator:=xlAnd
Range("J1:J100").Select
Selection.Copy
Sheets("Hilfsblatt").Select
Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Sheets("02_Objekt").Select
Selection.AutoFilter Field:=4
Sheets("Arbeitsblatt").Select
Range("G" & Range("F" & Rows.Count).End(xlUp).Row).Select
End If
' Application.EnableEvents = True
End Sub

In der unterstrichenen Zeile meldet er den Fehler.

Da ich zum ersten Mal mit der Funktion arbeite habe ich noch meine Probleme mit dem Aufbau diese Makros, aber vielleicht kann einer von euch mir weiterhelfen.

Gruß und besten dank im voraus

Helmut

Answer 1

Hallo,

diese Zeile sollte unterstrichen werden, hat aber nicht funktioniert


Range("J1:J100").Select

Gruß

Helmut

Answer 2

Hallo Helmut,

verzichte auf select
.

'Option Explicit

Private Sub worksheet_Change(ByVal Target As Range)
Application.EnableEvents = False
If Not Application.Intersect(Target, Range("F6:F1000")) Is Nothing Then
wert = Left(ActiveCell.Value, 3)
Sheets("02_Objekt").AutoFilter Field:=4, Criteria1:="=*" & wert & "*", Operator:=xlAnd
Range("J1:J100").Copy
With Sheets("Hilfsblatt")
.Range("A1").PasteSpecial Paste:=xlPasteFormats
End With
Sheets("02_Objekt").AutoFilter Field:=4
End If
' Application.EnableEvents = True
End Sub

Gruß Hajo

Answer 3

Hallo Hajo_Zi,

ich bin ein Stück weiter aber es sind noch nicht alle Probleme gelöst.
Der Pastebefehl funktioniert nach nicht richtig.

Hoffe es alleine hinzubekommen, aber erst mal Danke für die Hilfe

Gruß

Helmut

Answer 4

Hallo,

jetzt hängt das Makro in

Private Sub worksheet_Change(ByVal Target As Range)
'Application.EnableEvents = False
If Not Application.Intersect(Target, Range("F6:F1000")) Is Nothing Then
wert = Left(ActiveCell.Value, 3)
Sheets("02_Objekt").Select
Selection.AutoFilter Field:=4, Criteria1:="=*" & wert & "*", Operator:=xlAnd
Range("J1:J100").Copy
Sheets("Hilfsblatt").Select
Range("J1").Selectt
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Sheets("02_Objekt").Select
Selection.AutoFilter Field:=4
Sheets("Arbeitsblatt").Select
Range("G" & Range("F" & Rows.Count).End(xlUp).Row).Select
End If[
' Application.EnableEvents = True
End Sub

der nach vorne verschobenen Zeile auf, wenn ich die Zeile in

Range("J1").PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False

ändere habe ich eine Endlosschleife.

Gruß

Helmut

Answer 5

Hallo Helmut,

ich sehe das also richtig mein Vorschlag war für den Papierkorb.
Für den arbeite ich nicht. Ich bin dann raus.

Gruß hajo

Answer 6

Hallo,

richtig ist Range("J1").Select anstatt Range("J1").Selectt, aber das Problem bleibt, da im Makro es richtig war und ich beim Übertragen einen Fehler gemacht hatte.

Gruß

Helmut

Answer 7

Hallo Hajo_Zi,

Leider hatte ich bei deinem Vorschlag auch Probleme, er kopierte Daten aus dem "Arbeitsblatt", aber nach einigen Vesuchen habe ich es jetzt hinbekommen

Private Sub worksheet_Change(ByVal Target As Range)
'Application.EnableEvents = False
If Not Application.Intersect(Target, Range("F6:F1000")) Is Nothing Then
wert = Left(ActiveCell.Value, 3)
Sheets("02_Objekt").Select
Selection.AutoFilter Field:=4, Criteria1:="=*" & wert & "*", Operator:=xlAnd
With Sheets("02_Objekt")
.Range("J1:J100").Copy
End With
With Sheets("Hilfsblatt")
.Range("J1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
End With
Sheets("02_Objekt").Select
Selection.AutoFilter Field:=4
Sheets("Arbeitsblatt").Select
'Range("G" & Range("F" & Rows.Count).End(xlUp).Row).Select
End If
' Application.EnableEvents = True
End Sub

und das dank deiner Vorlage, da dort für mich wichtige Anhaltspunkte drin waren.

Noch mal herzlichen Dank für deine Hilfe.

Gruß

Helmut