Automatisch SVerweis einfügen und Resultat speichern. Und zwar nur die Werte

  • Excel

Es gibt 2 Antworten in diesem Thema. Der letzte Beitrag () ist von xored.

    Automatisch SVerweis einfügen und Resultat speichern. Und zwar nur die Werte

    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