Werte von geöffneter Tabelle in eine Andere Datei schreiben

12/03/2010 - 13:26 von Michael Karajan | Report spam
Hallo NG!

Ich habe folgende Problemstellung: Ich habe 2 Dateien. In jeder ist jeweils
eine Tabelle. Wenn in Spalte T der Datei1 der Tabelle MeineTabelle, ein Datum
eingetragen wird, dann sollen die Werte aus der Spalte C ausgelsen werden und
in der "Datei2, AndereTabelle" nach diesem Wert gesucht werden in der Spalte
D dieser Tabelle. Wenn gefunden wird dann soll das Datum aus der Datei,
MeineTabelle die eingegeben wurde in Spalte H der Tabelle "Datei2,
AndereTabelle" eingetragen werden.

Ich habe hier den kompletten Code die ich zusammengebastelt habe.
Funktioniert aber irgendwie nicht. Ich kann aber nicht nachvollziehen woran
das liegen könnte. Ich hoffe ihr könnt mir helfen:

Code:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Suchtext, PNr, KtoNr, GDat
Set Target = Intersect(Target, [R:T])
If Target Is Nothing Then Exit Sub
If Target.Rows.Count <> 1 Then Exit Sub
If Target.Row < 2 Then Exit Sub

ActiveSheet.Unprotect
With Target.EntireRow.Resize(, 20)

If IsDate(.Cells(1, "S")) Then

.Interior.ColorIndex = IIf(Year(.Cells(1, "S")) < 2010, 10, 50)
.Font.ColorIndex = IIf(.Cells(1, "H") <= 25, 0, 3)
.Font.Italic = False
.Font.Bold = True
If (Year(.Cells(1, "H"))) <= 25 Then
PNr.Value = (.Cells(1, "C"))
KNr.Value = (.Cells(1, "B"))
GDat.Value = (.Cells(1, "S"))
Windows("J:\xxx\xxx\xxx\Datei2.xls").Activate
Sheets("Tabelle1").Select
For i = 1 To (.Cells(Rows.Count, 1).End(xlUp).Row)
If .Cells(i, 4) = PNr Then
ThisWorkbook.Sheets("AndereTabelle").Cells(i, 8) =
GDat.Value
End If
Next
End If
ElseIf IsDate(.Cells(1, "R")) Then

.Interior.ColorIndex = IIf(Year(.Cells(1, "R")) < 2010, 4, 43)
.Font.ColorIndex = 1
.Font.Italic = False
.Font.Bold = True

ElseIf Trim(.Cells(1, "T")) <> "" Then

.Font.ColorIndex = 0
.Font.Italic = True
.Font.Bold = True
Select Case Trim(.Cells(1, "T"))
Case "ztt" To "ztt zzzzzzz": .Interior.ColorIndex = 27:
.Font.Italic = True: .Font.Bold = True
Case "s", "spàter": .Interior.ColorIndex = 39: .Font.Bold =
True: .Font.Italic = False
Case "G" To "G93": .Interior.ColorIndex = 22: .Font.ColorIndex =
49: .Font.Italic = False
Case "g" To "g93": .Interior.ColorIndex = 22: .Font.ColorIndex =
49: .Font.Italic = False
Case "T", "Telefon", "Tel.", "NE", "nE", "ne":
.Interior.ColorIndex = 40: .Font.Bold = True: .Font.Italic = False
Case "t", "telefon", "tel", "NE", "nE", "ne":
.Interior.ColorIndex = 40: .Font.Bold = True: .Font.Italic = False
Case "A" To "Aktion*": .Interior.ColorIndex = 46: .Font.Bold =
True: .Font.Italic = False
Case Else: .Interior.ColorIndex = 53: .Font.ColorIndex = 36:
.Font.Italic = False: .Font.Bold = False
End Select

Else

.Interior.ColorIndex = xlNone
.Font.ColorIndex = xlAutomatic
.Font.Italic = False
.Font.Bold = False

End If
End With
ActiveSheet.Protect AllowFiltering:=True

End Sub



Gruß
Michael
 

Lesen sie die antworten

#1 Michael Karajan
12/03/2010 - 13:39 | Warnen spam
Habe einen Fehler gefunden. Aber funktioniert nicht so wie ich es möchte.
Erhalte Fehlermeldung:


Code:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Suchtext, PNr, KtoNr, GDat
Set Target = Intersect(Target, [R:T])
If Target Is Nothing Then Exit Sub
If Target.Rows.Count <> 1 Then Exit Sub
If Target.Row < 2 Then Exit Sub

ActiveSheet.Unprotect
With Target.EntireRow.Resize(, 20)

If IsDate(.Cells(1, "S")) Then

.Interior.ColorIndex = IIf(Year(.Cells(1, "S")) < 2010, 10, 50)
.Font.ColorIndex = IIf(.Cells(1, "H") <= 25, 0, 3)
.Font.Italic = False
.Font.Bold = True
If .Cells(1, "H") <= 25 Then <= ! Fehler!
PNr.Value = (.Cells(1, "C"))
KNr.Value = (.Cells(1, "B"))
GDat.Value = (.Cells(1, "S"))
Windows("J:\xxx\xxx\xxx\Datei2.xls").Activate
Sheets("Tabelle1").Select
Zeilen = (Worksheets.Cells(Rows.Count, 1).End(xlUp).Row)
For i = 1 To Zeilen
If .Cells(i, 4) = PNr Then Workbooks.Open
Filename:="("J:\xxx\xxx\xxx\Datei2.xls")

ThisWorkbook.Sheets("AndereTabelle").Cells(i, 8) =
GDat.Value
End If
Next
End If
ElseIf IsDate(.Cells(1, "R")) Then

.Interior.ColorIndex = IIf(Year(.Cells(1, "R")) < 2010, 4, 43)
.Font.ColorIndex = 1
.Font.Italic = False
.Font.Bold = True

ElseIf Trim(.Cells(1, "T")) <> "" Then

.Font.ColorIndex = 0
.Font.Italic = True
.Font.Bold = True
Select Case Trim(.Cells(1, "T"))
Case "ztt" To "ztt zzzzzzz": .Interior.ColorIndex = 27:
.Font.Italic = True: .Font.Bold = True
Case "s", "spàter": .Interior.ColorIndex = 39: .Font.Bold =
True: .Font.Italic = False
Case "G" To "G93": .Interior.ColorIndex = 22: .Font.ColorIndex =
49: .Font.Italic = False
Case "g" To "g93": .Interior.ColorIndex = 22: .Font.ColorIndex =
49: .Font.Italic = False
Case "T", "Telefon", "Tel.", "NE", "nE", "ne":
.Interior.ColorIndex = 40: .Font.Bold = True: .Font.Italic = False
Case "t", "telefon", "tel", "NE", "nE", "ne":
.Interior.ColorIndex = 40: .Font.Bold = True: .Font.Italic = False
Case "A" To "Aktion*": .Interior.ColorIndex = 46: .Font.Bold =
True: .Font.Italic = False
Case Else: .Interior.ColorIndex = 53: .Font.ColorIndex = 36:
.Font.Italic = False: .Font.Bold = False
End Select

Else

.Interior.ColorIndex = xlNone
.Font.ColorIndex = xlAutomatic
.Font.Italic = False
.Font.Bold = False

End If
End With
ActiveSheet.Protect AllowFiltering:=True

End Sub



Gruß
Michael

Ähnliche fragen