Makro

  • Makro von Daniela vom 05.11.2003 16:14:39
Bild

Betrifft: Makro
von: Daniela
Geschrieben am: 05.11.2003 16:14:39

Hallo Zusammen

Kann mir jemand bei diesem Fall helfen. Leider reichen meinen VBA Kenntnisse für dies nicht mehr aus.

Vielen Dank im Voraus.


Problem:

Datei 1

A | B | C | D | E | P |

1 3 x

_______________________________________

Datei 2

A | B | C | D | ..... | F |
Wert1 Wert2 Datum


Wenn die Wertekombination einer Zeile der Spalte A und B der Datei 1 (im Beispiel 1 und 3) in der Datei 2 in einer Zeile der Spalten B und C ( Wert 1 und Wert2) vorkommt dann soll das Datum, welches sich in der Spalte F der Datei 2 befindet in die Spalte P der Datei 1 kopieren (x). Falls dies Kombination in Datei 2 nicht zu finden ist soll nichts in der Spalte P der Datei 1 eingtragen werden.

Bild


Betrifft: AW: Makro
von: Markus
Geschrieben am: 05.11.2003 16:36:26

Hallo,

vielleicht verstehe ich von der Skizze das Problem her nicht, aber: Wenn es nicht zu viele Daten sind, loop doch einfach durch.
For t = 1 to Ende
If tabelle1.cells(t,1) = tabelle2.cells(t,2) and tabelle1.cells(t,2) = tabelle2.cells(t,3) then tabelle1.cells(t,p) = tabelle2.cells(t,f)
netx t

???


Bild


Betrifft: AW: Makro
von: Markus
Geschrieben am: 05.11.2003 16:37:30

OOps,

kam gerade aus einer anderen Sprache: Zuweisung der Zellen zu Tabellen nicht über diese Notation, sondern "Worksheets("Tabelle1").Cells(.... etc.

Markus


Bild


Betrifft: AW: Makro
von: Klaus Schubert
Geschrieben am: 05.11.2003 17:01:42

Hallo Daniela,

hier mal auf die Schnelle etwas Code, bitte ausgiebig testen (ich hoffe,er funktioniert in deinem Sinne). Die Namen der Dateien und der entsprechenden Tabellblätter bitte anpassen:


Sub Vergleichen()
Dim Datei1 As Object, Datei2 As Object, i1 As Integer, i2 As Integer
Dim EndeDatei1 As Integer, EndeDatei2 As Integer
Set Datei1 = Workbooks("Mappe1.xls").Sheets("Tabelle1")'Namen anpssen
Set Datei2 = Workbooks("Mappe2.xls").Sheets("Tabelle1")'Namen anpassen
EndeDatei1 = Datei1.Cells(Cells.Rows.Count, 1).End(xlUp).Row
EndeDatei2 = Datei2.Cells(Cells.Rows.Count, 2).End(xlUp).Row
For i1 = 1 To EndeDatei1
For i2 = 1 To EndeDatei2
If Datei1.Cells(i1, 1) = Datei2.Cells(i2, 2) And Datei1.Cells(i1, 2) = Datei2.Cells(i2, 3) Then
Datei2.Cells(i2, 6).Copy Datei1.Cells(i1, 16)
Exit For
Else
Datei1.Cells(i1, 16) = ""
End If
Next i2
Next i1
End Sub


Gruß Klaus


Bild


Betrifft: AW: Makro
von: Daniela
Geschrieben am: 06.11.2003 07:35:15

Vielen Dank für Deine rasche Hilfe. Leider bin ich dennoch an einer Kleinigkeit hängen geblieben. Und zwar habe ich die Dateinamen und die Sheetnames angepasst dennoch bringt er nun die Fehlermeldung "Run-time error '9': Subscript out of range". Ich nehme an, dass das daran liegt, dass beide Dateien zwar unter dem selben Pfad gespeichert sind das System aber die zweite Datei nicht finden kann. Also habe ich darauf versucht dies so einzugeben:

Set Datei2 = Workbooks("C:\........\...xls").Sheets("close_out_final_vis")

leider geht dies nicht. Was habe ich falsch gemacht?


Bild


Betrifft: AW: Makro
von: Klaus Schubert
Geschrieben am: 06.11.2003 17:19:07

Hallo Daniela,

ich war davon ausgegangen, das die zweite Arbeitsmappe auch geöffnet ist,deshalb der Fehler. Hier nun geänderter Code, wobei die zweite Arbeitsmappe geöffnet wird und dann nach der Prozedur, ohne gespeichert zu werden, wieder geschlossen wird. der Code muß in der Datei 1 stehen, die Datei 2 wird aufgerufen:


Sub Vergleichen()
Dim Datei1 As Object, Datei2 As Object, i1 As Integer, i2 As Integer
Dim EndeDatei1 As Integer, EndeDatei2 As Integer
Dim NameDatei1 As String, NameDatei2 As String, Pfad As String
Dim TabelleDatei1 As String, TabelleDatei2 As String
Application.ScreenUpdating = False
Pfad = "C:\Dokumente und Einstellungen\Daniela\Eigene Dateien\" 'Pfad anpassen
NameDatei1 = "Mappe1.xls" 'Namen anpassen
TabelleDatei1 = "Tabelle1" 'Namen anpassen
NameDatei2 = "Mappe2.xls" 'Namen anpassen
TabelleDatei2 = "Tabelle1" 'Namen anpassen
Workbooks.Open Filename:=Pfad & NameDatei2 'Zweite Arbeitsmappe öffnen
Set Datei1 = Workbooks(NameDatei1).Sheets(TabelleDatei1)
Set Datei2 = Workbooks(NameDatei2).Sheets(TabelleDatei2)
EndeDatei1 = Datei1.Cells(Cells.Rows.Count, 1).End(xlUp).Row
EndeDatei2 = Datei2.Cells(Cells.Rows.Count, 2).End(xlUp).Row
For i1 = 1 To EndeDatei1
For i2 = 1 To EndeDatei2
If Datei1.Cells(i1, 1) = Datei2.Cells(i2, 2) And Datei1.Cells(i1, 2) = Datei2.Cells(i2, 3) Then
Datei2.Cells(i2, 6).Copy Datei1.Cells(i1, 16)
Exit For
Else
Datei1.Cells(i1, 16) = ""
End If
Next i2
Next i1
Workbooks(NameDatei2).Close savechanges:=False 'Zweite Arbeitsmappe ohne speichern schließen
Application.ScreenUpdating = True
End Sub



Bild

Beiträge aus den Excel-Beispielen zum Thema " User Form: Einträge autom. speichern"