Zellen automatisch in neue Tabelle/Datei kopieren

[lorwagner12]

Hey Leute, habe folgendes Problem und komme nicht voran. Ich habe euch unten meine Excel-Datei hochgeladen wo ich vergleiche der Spalten durchführe und dann falls diese gleich sind, einen bestimmten Wert ausgibt. Nun meine Frage. Wie schaffe ich es, dass ich die "ausgespuckten" Werte automatisch in ein neues Dokument kopiert werden und falls neue Daten in die einzelnen Spalten hinzukommen, bei einem Match der Name auch automatisch in die neue Datei kopiert werden. Ich hoffe ihr könnt mein Anliegen verstehen.
Danke

[AlterDresdner]

Hallo,
Du willst erreichen (das ist eine Frage!):
wenn die Mengen in einer Zeile übereinstimmen, soll der Name in eine Spalte einer neuen Datei ausgegeben werden?
Das ließe sich sinnvollerweise nur über ein manuell zu startendes Makro erreichen.
Ein automatischer Start bei jeder Änderung erzeugt jeders Mal eine neue Datei.... das willst Du nicht wirklich.
Wenn ich Deine Gedanken richtig erraten habe, dann sag es, ansonsten formuliere Deine WÜnsche.

[lorwagner12]

Ja genau, dass suche ich. Dass mit dem ausspucken des Namens hab ich schon geschafft, aber das speichern in einer anderen Datei eben noch nicht.

[AlterDresdner]

Hallo,

Code:

Sub NeueDatei()
'es werden alle Namen gesammelt, bei denen Nummer und Menge übereinstimmen
'MengeX steht in MXSpalte+1, der Name in Spalte M1Spalte+2
'Die gesammelten Namen werden in eine neue Datei ausgegeben
'Es können Namen auch doppelt ausgegeben werden
Const M1Spalte = 1 'Spalte für Nummer 1
Const M2Spalte = 5 'Spalte für Nummer 2
Dim zeile As Long, Erg() As String, anz As Long, FName, NewWB As Object
  ReDim Erg(1 To 1)
  For zeile = 2 To Cells(Rows.Count, M1Spalte).End(xlUp).Row
    If Cells(zeile, M1Spalte) = Cells(zeile, M2Spalte) And (Cells(zeile, M1Spalte + 1) = Cells(zeile, M2Spalte + 1)) Then
      anz = anz + 1
      ReDim Preserve Erg(1 To anz)
      Erg(anz) = Cells(zeile, M1Spalte + 2)
    End If
  Next zeile
  If anz > 0 Then
    Set NewWB = Workbooks.Add
    For zeile = 1 To anz
      NewWB.Sheets(1).Cells(zeile, 1) = Erg(zeile)
    Next zeile
    FName = Application.GetSaveAsFilename("", "Excel-Arbeitsmappe (*.xlsx),*.xlsx", , "Datei speichern unter")
    If VarType(FName) <> 11 Then ActiveWorkbook.SaveAs Filename:=FName, FileFormat:=xlOpenXMLWorkbook
  Else
    MsgBox "keine Übereinstimmungen gefunden"
  End If
End Sub

sollte das beschriebene tun.

[lorwagner12]

Vielen Dank. Und wie füge ich dass jetzt ein? Sorry, bin ein totaler Anfänger

[AlterDresdner]

Hallo,
der Anhang zeigt es.
Das Makro kannst Du sehen durch:
Drücken von Alt+F11, dann öffnet sich der VBA-Editor. Dort findest Du das Makro u7nter der Tabelle1 (links im Projekt-Explorer).

[lorwagner12]

Danke dir. Zwei kleine Fragen noch:

1) Wie hast du diesen Knopf hinbekommen?
2) Der für meine Arbeit relevante Befehl lautet so:

Code:

=IFERROR(INDEX(Daten_A.xlsx!Tabelle1[AA,MATCH(Tabelle1[Nominal (A)]&Tabelle1[ISIN],Daten_Auslieferungen.xlsx!Tabelle1[AB_B]&VLOOKUP(Daten_A.xlsx!Tabelle1[AV_V],[ISIN.xlsx]Tabelle1!R2C1:R11435C2,2,FALSE),0)),""Keine Übereinstimmung"")

Kann ich dein VBA-Code dafür auch benutzen oder muss ich diesen noch anpassen? Falls ja, welche Änderungen muss ich wo vornehmen.

Danke du rettest echt Leben!

[AlterDresdner]

Hallo,
den Knopf erzeugt man durch das Menü Einfügen-Formen und dann Auswahl und Aufziehen des Gewünschten.
Den text und das Makro bindet man per rechtren Mausklick daran.
Mit Deiner Formel kann ich so nicht viel anfangen, vermute aber mal, dass eigentlich nicht 2 Spalten auf dem gleichen Blatt, sondern in zwei verschiedenen Dateien verglichen werden sollen.
Der Codeteil
  For zeile = 2 To Cells(Rows.Count, M1Spalte).End(xlUp).Row
    If Cells(zeile, M1Spalte) = Cells(zeile, M2Spalte) And (Cells(zeile, M1Spalte + 1) = Cells(zeile, M2Spalte + 1)) Then
beschreibt den Vergleich und müsste an Deine Bedingungen angepasst werden.
Ich mit mienem Uralt-Excel2010 kann Deine Formel nicht auflösen.
Entweder beschreibst Du mir verbal, welche Spalte welcher Datei womit verglichen werden soll und aus welcher Spalte welcher Datei dann etwas ausgegeben wird,
oder Du stellst mir die zwei Dateien mit Demodaten ins Forum.
Und: Stört die doppelte AUsgabe von Treffern? Sie ließe sich verhindern.

[lorwagner12]

Okay danke. Ja genau, es ist eine "Abfrage" über zwei Dateien hinweg, wobei diese sich regelmäßig ändern (daher auch das Makro).

Code:

=WENNFEHLER(INDEX(Daten_Aus.xlsx!Tabelle1[AA];VERGLEICH(Tabelle1[Nominal (o)]&Tabelle1[ISIN];Daten_Aus.xlsx!Tabelle1[STK]&Daten_Aus.xlsx!Tabelle1[ISIN];0));"Kein Match")

Im Grunde stehen die relevanten Daten in den Dokumenten Daten_Aus.xlsx und dem Dokument in welchem der Befehl "durchgeführt" wird (daher auch kein Name, zur vereinfachten Darstellung Original.xlsx). Zunächst sollen die Werte der Spalte Nominal (o) und ISIN aus dem Orginal.xlsx mit denen Werten der Spalten STK und ISIN abgeglichen werden und wenn die Zeilenkombination aus der Orignail.xlsx irgendwo in Daten_Aus.xlsx zu finden ist, dann soll der Befehl den dementsprechnenden Wert aus der Spalte AA ausgeben. Falls es kein Match gibt, dann soll der "Kein Match" ausgeben. Die Werte für die es einen Match gibt, diese sollen dann automatisch in eine neue Datei kopiert werden. Die Datein kann ich dir aus Datenschutzrechtlichen Gründen leider nicht schicken. Hoffe du kannst trotzdem verstehen was ich meine und mir damit helfen.

[AlterDresdner]

Hallo,
die Aussicht auf die Lebensrettungsmjedaille brachte mich zu folgendem Code
(bitte Änderung des Makronamens berücksichtigen!):
Sub MatchesSammeln()
'es werden alle Einträge gesammelt, bei denen ISIN und STK/Nominal(o) übereinstimmen
'Bei Match wird Spalte AA in eine neue Datei ausgegeben
'Es können Werte AA auch doppelt ausgegeben werden
Const Isin = "ISIN"
Const STK1 = "Nominal (o)"
Const STK2 = "STK"
Const AA = "AA"
Const Datei = "Daten_Aus.xlsx"
Dim SIsin1 As Long, SIsin2 As Long, SStk1 As Long, Sstk2 As Long, Saa As Long
Dim zeile As Long, Erg() As String, anz As Long, FName, NewWB As Object, found, firstaddr
Dim Q1 As Object, Q2 As Object
  Set Q1 = ThisWorkbook.Sheets(1)
  On Error Resume Next
  Set Q2 = Workbooks(Datei).Sheets(1)
  On Error GoTo 0
  If Q2 Is Nothing Then 'Datei öffnen
OM:    FName = Application.GetOpenFilename("Exceldateien (*.xlsx), *.xlsx", , "Datei " & Datei & " öffnen")
    If FName = False Then Exit Sub
    If InStr(1, FName, Datei) = 0 Then
      MsgBox "Der Dateiname entspricht nicht der Vorgabe " & Datei & ". Dateiauswahl wiederholen"
      GoTo OM
    End If
    Set Q2 = Workbooks.Open(FName)
    Set Q2 = Q2.Sheets(1)
  End If
  On Error Resume Next
  With Q1 'Spalten bestimmen
    SStk1 = .Rows(1).Find(what:=STK1, lookat:=xlWhole, MatchCase:=True).Column
    SIsin1 = .Rows(1).Find(what:=Isin, lookat:=xlWhole, MatchCase:=True).Column
  End With
  With Q2
    Sstk2 = .Rows(1).Find(what:=STK2, lookat:=xlWhole, MatchCase:=True).Column
    SIsin2 = .Rows(1).Find(what:=Isin, lookat:=xlWhole, MatchCase:=True).Column
    Saa = .Rows(1).Find(what:=AA, lookat:=xlWhole, MatchCase:=True).Column
  End With
  If Err.Number > 0 Then
    MsgBox "Eine der Spaltenüberschriften " & STK1 & ", " & STK2 & ", " & Isin & ", " & AA & " wurde nicht gefunden.", vbCritical
    Exit Sub
  End If
  ReDim Erg(1 To 1)
  For zeile = 2 To Q1.Cells(Rows.Count, SIsin1).End(xlUp).Row
    Set found = Q2.Columns(SIsin2).Find(what:=Q1.Cells(zeile, SIsin1), lookat:=xlWhole)
    If Not found Is Nothing Then
      firstaddr = found.Address
      Do
        If Q1.Cells(zeile, SStk1) = Q2.Cells(found.Row, Sstk2) Then 'Match found
          anz = anz + 1
          ReDim Preserve Erg(1 To anz)
          Erg(anz) = Q2.Cells(found.Row, Saa)
        End If
        Set found = Q2.qolums(SIsin2).FindNext(found)
      Loop Until found.Address = firstaddr
    End If
  Next zeile
  If anz > 0 Then
    Set NewWB = Workbooks.Add
    For zeile = 1 To anz
      NewWB.Sheets(1).Cells(zeile, 1) = Erg(zeile)
    Next zeile
    FName = Application.GetSaveAsFilename("", "Excel-Arbeitsmappe (*.xlsx),*.xlsx", , "Datei speichern unter")
    If VarType(FName) <> 11 Then ActiveWorkbook.SaveAs Filename:=FName, FileFormat:=xlOpenXMLWorkbook
  Else
    MsgBox "kein Match"
  End If
End Sub

Wenn etwas nicht klappt, schreib bitte genau, was nicht klappt, und poste die Dateien ohne Daten, aber mit den Spaltenüberschriften, ein paar Testdaten mache ich mir dann zurecht.