Hallo zusammen,
ich bin recht neu in VBA. Programmiere mehr mit PHP und HTML.
Mein Zeil
Eine marge.xls
Sheet1 Start Button
Sheet2 Tabelle mit MarktID, NAME, Automarke
Beim klicken auf den "Start" Button soll ein Fenster geöffnet werden um eine Excel Datei auszuwählen. (Beispiel autphaus.xls)
Wähle ich Sie aus, wird automatisch in die Datei autohaus.xls mit zwei neuen Spalten ergänzt. A und B. Also die ersten beiden Spalten.
Jetzt soll das Script in der marge.xls die "Markt SAP ID" aus dem Sheed2 mit der "Markt SAP ID" spalte
(in Original autohaus.xls B nach dem hinzufügen der beiden Spalten logischer weise auf D)
in autohaus.xls verglichen werden. Mit einem SVerweis.
z.B. wenn in Sheet2 folgendes steht:
33, Müller Peter, Audi
44, Schmidt Olliver, BMW
und in der autohus.xls
München, 44, Wiesenstrasse 2
Soll dann das Ergebnis so aussehen wenn es fertig ist:
Schmidt Oliver, BMW, München, 44, Wiesenstrasse 2
Jetzt soll das Ergebniss als neue Datei gespeichert werden, ohne Formeln nur mit Werten unter
IDP+(AktuellesDatum).xls
So sieht mein Code aus:
Sub Vergleichen()
' Variablen deklarieren
Dim Marge As Worksheet
Dim Vergleich As Workbook
Dim Datei As Variant
Dim LetzteZeile As Long
Dim LetzteZeile2 As Long
Dim i As Long
Dim j As Long
' Blätter setzen
Set Marge = ThisWorkbook.Sheets("Sheet2")
' Datei öffnen
Datei = Application.GetOpenFilename("Excel-Dateien (*.xlsx), *.xlsx", 1, "Datei öffnen", "Öffnen", False)
If Datei = False Then Exit Sub
On Error Resume Next
Set Vergleich = Workbooks.Open(Datei)
If Vergleich Is Nothing Then
MsgBox "Die Datei konnte nicht geöffnet werden", vbCritical
Exit Sub
End If
On Error GoTo 0
' Letzte Zeile in beiden Blättern finden
LetzteZeile = Marge.Cells(Rows.Count, "A").End(xlUp).Row
LetzteZeile2 = Vergleich.Sheets(1).Cells(Rows.Count, "A").End(xlUp).Row
' Vergleich starten
For i = 2 To LetzteZeile
For j = 2 To LetzteZeile2
If Marge.Cells(i, "A").Value = Vergleich.Sheets(1).Cells(j, "A").Value Then
Marge.Cells(i, "B").Value = Vergleich.Sheets(1).Cells(j, "B").Value
Marge.Cells(i, "C").Value = Vergleich.Sheets(1).Cells(j, "C").Value
Exit For
End If
Next j
Next i
' Vergleich beenden
Vergleich.Close savechanges:=False
' Endprodukt speichern
ThisWorkbook.Save
End Sub
Aber es geht einfach nicht.
Ich finde den Fehler nicht. Wenn ich auf Start klicke, sollte das Fenster aufgehen. Das passiert nicht. Stadtdessen bekomme ich die Meldung:
Laufzeifehler 1004 Fehler der Methode "GetOpenFilename" des Objektes "_Aplicattion".
Habt Ihr eine Idee?
Habe noch mal was angepasst. Hier srcipt nummer zwei. Hegt aber auch nicht..
Sub StartButton_Click()
Dim FileDialog As Object
Set FileDialog = Application.FileDialog(msoFileDialogFilePicker)
With FileDialog
.AllowMultiSelect = False
.Title = "Wähle die Datei aus, die zusammengeführt werden soll"
.Filters.Clear
.Filters.Add "Excel-Dateien", "*.xls*"
If .Show = True Then
Dim FileName As String
FileName = .SelectedItems(1)
Dim WbDest As Workbook
Set WbDest = ThisWorkbook
Dim WsDest As Worksheet
Set WsDest = WbDest.Sheets("Sheet2")
Dim WbSource As Workbook
Set WbSource = Workbooks.Open(FileName)
Dim WsSource As Worksheet
Set WsSource = WbSource.Sheets(1)
WsSource.Range("A1").EntireColumn.Insert
WsSource.Range("B1").EntireColumn.Insert
WsSource.Range("A1").Value = "NAME"
WsSource.Range("B1").Value = "Automarke"
Dim LastRow As Long
LastRow = WsDest.Cells(WsDest.Rows.Count, "A").End(xlUp).Row
Dim i As Long
For i = 2 To LastRow
Dim MarketID As Long
MarketID = WsDest.Cells(i, "A").Value
Dim Name As String
Name = WsDest.Cells(i, "B").Value
Dim Marke As String
Marke = WsDest.Cells(i, "C").Value
Dim FindRange As Range
Set FindRange = WsSource.Range("D1:D" & WsSource.Cells(WsSource.Rows.Count, "D").End(xlUp).Row)
Dim FoundCell As Range
Set FoundCell = FindRange.Find(MarketID, LookAt:=xlWhole)
If Not FoundCell Is Nothing Then
Dim RowIndex As Long
RowIndex = FoundCell.Row
WsSource.Cells(RowIndex, "A").Value = Name
WsSource.Cells(RowIndex, "B").Value = Marke
End If
Next i
WbSource.SaveAs FileName & "(zusammengeführt)" & Format(Date, "dd-mm-yyyy") & ".xls", xlExcel8
WbSource.Close
End If
End With
End Sub
ich bin recht neu in VBA. Programmiere mehr mit PHP und HTML.
Mein Zeil
Eine marge.xls
Sheet1 Start Button
Sheet2 Tabelle mit MarktID, NAME, Automarke
Beim klicken auf den "Start" Button soll ein Fenster geöffnet werden um eine Excel Datei auszuwählen. (Beispiel autphaus.xls)
Wähle ich Sie aus, wird automatisch in die Datei autohaus.xls mit zwei neuen Spalten ergänzt. A und B. Also die ersten beiden Spalten.
Jetzt soll das Script in der marge.xls die "Markt SAP ID" aus dem Sheed2 mit der "Markt SAP ID" spalte
(in Original autohaus.xls B nach dem hinzufügen der beiden Spalten logischer weise auf D)
in autohaus.xls verglichen werden. Mit einem SVerweis.
z.B. wenn in Sheet2 folgendes steht:
33, Müller Peter, Audi
44, Schmidt Olliver, BMW
und in der autohus.xls
München, 44, Wiesenstrasse 2
Soll dann das Ergebnis so aussehen wenn es fertig ist:
Schmidt Oliver, BMW, München, 44, Wiesenstrasse 2
Jetzt soll das Ergebniss als neue Datei gespeichert werden, ohne Formeln nur mit Werten unter
IDP+(AktuellesDatum).xls
So sieht mein Code aus:
Sub Vergleichen()
' Variablen deklarieren
Dim Marge As Worksheet
Dim Vergleich As Workbook
Dim Datei As Variant
Dim LetzteZeile As Long
Dim LetzteZeile2 As Long
Dim i As Long
Dim j As Long
' Blätter setzen
Set Marge = ThisWorkbook.Sheets("Sheet2")
' Datei öffnen
Datei = Application.GetOpenFilename("Excel-Dateien (*.xlsx), *.xlsx", 1, "Datei öffnen", "Öffnen", False)
If Datei = False Then Exit Sub
On Error Resume Next
Set Vergleich = Workbooks.Open(Datei)
If Vergleich Is Nothing Then
MsgBox "Die Datei konnte nicht geöffnet werden", vbCritical
Exit Sub
End If
On Error GoTo 0
' Letzte Zeile in beiden Blättern finden
LetzteZeile = Marge.Cells(Rows.Count, "A").End(xlUp).Row
LetzteZeile2 = Vergleich.Sheets(1).Cells(Rows.Count, "A").End(xlUp).Row
' Vergleich starten
For i = 2 To LetzteZeile
For j = 2 To LetzteZeile2
If Marge.Cells(i, "A").Value = Vergleich.Sheets(1).Cells(j, "A").Value Then
Marge.Cells(i, "B").Value = Vergleich.Sheets(1).Cells(j, "B").Value
Marge.Cells(i, "C").Value = Vergleich.Sheets(1).Cells(j, "C").Value
Exit For
End If
Next j
Next i
' Vergleich beenden
Vergleich.Close savechanges:=False
' Endprodukt speichern
ThisWorkbook.Save
End Sub
Aber es geht einfach nicht.
Ich finde den Fehler nicht. Wenn ich auf Start klicke, sollte das Fenster aufgehen. Das passiert nicht. Stadtdessen bekomme ich die Meldung:
Laufzeifehler 1004 Fehler der Methode "GetOpenFilename" des Objektes "_Aplicattion".
Habt Ihr eine Idee?
Habe noch mal was angepasst. Hier srcipt nummer zwei. Hegt aber auch nicht..
Sub StartButton_Click()
Dim FileDialog As Object
Set FileDialog = Application.FileDialog(msoFileDialogFilePicker)
With FileDialog
.AllowMultiSelect = False
.Title = "Wähle die Datei aus, die zusammengeführt werden soll"
.Filters.Clear
.Filters.Add "Excel-Dateien", "*.xls*"
If .Show = True Then
Dim FileName As String
FileName = .SelectedItems(1)
Dim WbDest As Workbook
Set WbDest = ThisWorkbook
Dim WsDest As Worksheet
Set WsDest = WbDest.Sheets("Sheet2")
Dim WbSource As Workbook
Set WbSource = Workbooks.Open(FileName)
Dim WsSource As Worksheet
Set WsSource = WbSource.Sheets(1)
WsSource.Range("A1").EntireColumn.Insert
WsSource.Range("B1").EntireColumn.Insert
WsSource.Range("A1").Value = "NAME"
WsSource.Range("B1").Value = "Automarke"
Dim LastRow As Long
LastRow = WsDest.Cells(WsDest.Rows.Count, "A").End(xlUp).Row
Dim i As Long
For i = 2 To LastRow
Dim MarketID As Long
MarketID = WsDest.Cells(i, "A").Value
Dim Name As String
Name = WsDest.Cells(i, "B").Value
Dim Marke As String
Marke = WsDest.Cells(i, "C").Value
Dim FindRange As Range
Set FindRange = WsSource.Range("D1:D" & WsSource.Cells(WsSource.Rows.Count, "D").End(xlUp).Row)
Dim FoundCell As Range
Set FoundCell = FindRange.Find(MarketID, LookAt:=xlWhole)
If Not FoundCell Is Nothing Then
Dim RowIndex As Long
RowIndex = FoundCell.Row
WsSource.Cells(RowIndex, "A").Value = Name
WsSource.Cells(RowIndex, "B").Value = Marke
End If
Next i
WbSource.SaveAs FileName & "(zusammengeführt)" & Format(Date, "dd-mm-yyyy") & ".xls", xlExcel8
WbSource.Close
End If
End With
End Sub