Frage bei einem Makro

Dieses Thema Frage bei einem Makro im Forum "Microsoft Office Suite" wurde erstellt von Ein Gast, 5. Feb. 2005.

Thema: Frage bei einem Makro Hallo liebe Leute, wie ich oft sehe, werden hier Fragen kompetent und schnell beantwortet. Ich habe folgendes...

  1. Hallo liebe Leute,

    wie ich oft sehe, werden hier Fragen kompetent und schnell beantwortet. Ich habe folgendes Anliegen, was ich gerne mit einem Makro lösen würde. Leider habe ich in dieser Sache überhaupt keine Kenntnisse. Es würde mich freuen, wenn ihr mir bei dem folgenden Problem hilft und zudem sagt, wie ich am besten das Programmieren von Makros lernen kann.

    Also folgendes:
    Ich habe zwei verschiedene Excel Dateien (benutze MS Office 2003). In der einen habe ich Daten, deren Informationen irgendwie in die andere Datei müssen. Bisher habe ich immer nur manuell kopiert und die Inhalte in die andere eingefügt. Das würde ich gerne mittels eines Makros machen lassen.

    Die wichtigen (mittels einer Formel erstellten) Daten in der Quelldatei stehen in den Spalte M und N. Genau die gleichen Daten, aber in einer willkürlichen Reihenfolge (das ist es ja was es so schwierig macht, sonst hätte ich keine Probleme alles schnell rüberzukopieren), stehen in der Zieldatei in den Spalten F und G. Nun soll das Makro folgendes überprüfen:

    Steht in der Zieldatei der Wert XYZ (wie Müller Maier) in der Spalte F, dann soll der Wert von Spalte M aus der Quelldatei übernommen werden.

    Steht aber in der Zieldatei der wert XYZ (wie Müller Maier) in der Spalte G, soll dann der Wert von Spalte N aus der Quelldatei übernommen werden.

    Das Makro muss also in den beiden Dateien die Gleichheit der Werte erkennen, d.h. Müller Maier in der richtigen Spalte ersetzen und nicht aus Versehen z.B. den Kunden Peter mit dem gleichen Wert überschreiben.

    Wäre Euch sehr dankbar, wenn ihr eine Lösung für mich findet. Mir hilft aber der Lösungsvorschlag alles nach Namen sortieren zu lassen und dann die Werte schnell einzufügen nicht weiter. Dazu ist die Struktur zu komplex, um das so zu lösen.
     
  2. Hallo->Ein Gast' (langweiliger Name-> nicht angemeldet ?),

    die Erklärung ist schon ziemlich ausführlich, hört sich aber so an, als würde der Suchbegriff überschrieben.

    Fragen:
    1) aus welcher Datei willst Du den Makro aufrufen?
    a) aus Quelldatei
    b) aus Zieldatei
    c) aus einer dritten Datei

    2) Sollen die Dateien automatisch geöffnet werden, falls sie noch nicht geöffnet sind, oder soll dann eine Fehlermeldung kommen ?

    2)a) Haben die Mappen mehrere Blätter?

    3) den Suchvorgang bitte nochmal an 2 Beispielen erklären
    (nach dem Motto: in Datei-Quelle steht in Spalte ..., in der Ziel-Datei steht in Spalte ..., und dann alle beteiligten Spalten nennen, am besten die Spaltennamen )
    Wohin ? Spalte F überschreiben ?

    4) Ab welcher Zeile stehen
    - in der Quelldatei relevante Werte
    - in der Zieldatei relevante Werte

    5) gibt es leere Zeilen zwischen den Daten ?

    6) Gibt es nach den relevaten Daten-Zeilen noch weitere?
    (Was  ist das Ende-Kriterium ?)

    Gruß Matjes  :)
     
  3. Hallo Matjes, danke für deine schnelle Anwtwort. :):D :D

    Sorry das ist ein sehr langweiliger Name, mir fiel aber nichs besseres ein. Zudem schien es mir nicht sehr wichtig. :-\

    zu Frage 1)Makro würde ich wohl aus dem persönlichen Order aufrufen, zudem hätte ich beide Dateien sowieso gleichzeitig auf, sodass es egal sein könnte, oder?

    zu Frage 2)Ich würde die Dateien automatisch öffnen, und dann erst das Makro drüberlaufen lassen

    zu Frage 3)In der Zieldatei gibt es nur ein Blatt, in der Quelldatei jeodoch mehrere Blätter (Sheets), da würde ich aber zur Not das Makro dann mehrmals durchlaufen lassen.

    Jetzt noch ein exakteres Beispiel, was das Makro überprüfen soll: Steht in der Zieldatei in der Spalte F (und nur dort!) ein Eintrag z.B. mit Müller F., so soll aus der Spalte M (und nur von dort!) der Quelldatei der neue Wert von Müller F. (der könnte so aussehen = Müller F. 1804575 21545) eingetragen werden (Inhalte einfügen lassen, da das irgendwelche Formel sind). Natürlich auch in der gleichen Zelle und nicht woanders.

    Steht in der Zieldatei der Eintrag mit Müller F. aber in der Spalte G (statt in der Spalte F), dann soll nur aus der Spalte N (statt aus der Spalte M) der Quelldatei der neue Wert von Müller F. (der könnte klein bisschen anders aussehen als der Wert aus der Spalte M, z.B. = Müller F. 5542212 645445) eingetragen werden (auch hier Inhalte einfügen lassen).

    zu Frage 4)- in der Quelldatei ab zeile 4
    - in der Zieldatei ab Zeile 3

    zu Frage 5) ja. gibt es. So wie oben beim Beispiel Müller F. 1804575 21545

    zu Frage 6)nee, eigentlich gibt es keine weiteren relevanten zeilen mehr. In der Zieldatei sind es maximal 100-120 Zeilen.

    Das Ende-Kriterium könnte folgender Fall sein: Das Makro hat alle Einträge in der Zieldatei mit den neuen Werten aus der Quelldatei überschrieben und findet keine weiteren Einträge, die aktualisiert werden können. Wenn es in der Zieldatei nur noch Werte gibt wie Peter Kohl, aber es findet in der Quelldatei keinen relevanten wert oder sind alle Zeilen aktualisiert mit den neuen Daten, ist die Prüfung beendet.
     
  4. Hallo immer noch Gast  ;D ,

    ich hab deine Angaben mal in einen Makro gegossen.
    Die PfadDatei-Namen für Quelle und Ziel mußte Du noch deinen Gegebenheiten anpassen.

    Die ersten Male bitte auf einer Kopie austesten.
    Ich hab den Makro zwar auch getestet, aber vielleicht hab ich noch etwas übersehen.
    Und dann bitte Ergebnis melden.

    Gruß Noch ein Matjes  ;D

    Code:
    '***********************************************************
    Sub QuelleZielAbgleichen()
    'Funktion:
    'Es werden Daten aus der Quelldatei in die Zieldatei übertragen
    '
    'Voraussetzung zum Aufruf des Makros:
    '- Quelldatei ist geöffnet und hat nur ein Arbeitsblatt
    '- Zieldatei ist geöffnet und das zu aktualisierende Arbeitsblatt ist aktiv
    '- die Suchbegriffe müssen eindeutig sein !!!
    '
    '1)  Voraussetzungen prüfen -> Bei Fehler Meldung + Abbruch
    '2   Auf dem Zielblatt werden die beiden relevanten Spalten untersucht.
    '2.1 Ist die Zelle nicht leer und
    '    der Inhalt hat als letztes Zeichen nicht eine Zahl
    '    ist dies der nächste Suchbegriff
    '2.2 Suchbegriff in korrepondierender Spalte des Quellblattes suchen
    '    Wenn nicht gefunden -> nächste Zeile im Quellblatt untersuchen -> 2.1
    '2.3 Inhalte der gefunden Zelle in Zielblatt kopieren
    '3.  Fertigmeldung und Protokoll ausgeben
    '***********************************************************
    
     ->### anpassen ###################################################
      Const s_QUELLDATEI As String = c:\download\QuelleTest.xls
      Const l_Q_ERSTEZEILE = 4   -> erste Zeile, ab der gesucht wird
                                 -> ab dieser Zeile folgen nur Wertezeilen
      Const l_Q_SP_M As Long = 13-> entspricht M
      Const l_Q_SP_N As Long = 14-> entspricht N
      
      Const s_ZIELDATEI As String = c:\download\ZielTest.xls
      Const l_Z_ERSTEZEILE = 3   -> erste Zeile, ab der gesucht wird
                                 -> ab dieser Zeile folgen nur Wertezeilen
      Const l_Z_SP_F As Long = 6 -> entspricht Spalte F
      Const l_Z_SP_G As Long = 7 -> entspricht Spalte G
     ->### anpassen Ende ##############################################
      
      Dim wbz As Workbook, wsz As Worksheet
      Dim wbq As Workbook, wsq As Worksheet
      Dim fp() As String, fp_cnt As Long->Merkfeld positives Suchergebnis
      Dim fn() As String, fn_cnt As Long->Merkfeld positives Suchergebnis
      Dim x As Long, s_tmp As String
      
     ->Merk-Felder initialisieren
      fp_cnt = 0: ReDim fp(1 To 1)
      fn_cnt = 0: ReDim fn(1 To 1)
      
    '1)  Voraussetzungen prüfen -> Bei Fehler Meldung + Abbruch
      If Not VoraussetzungQuelldateiPruefen( _
                s_QUELLDATEI, wbq, wsq) Then GoTo Aufraeumen
      If Not VoraussetzungZieldateiPruefen( _
                s_ZIELDATEI, wbz, wsz) Then GoTo Aufraeumen
       
      Call VergleichenUndUebertragen( _
                wbq, wsq, l_Q_ERSTEZEILE, l_Q_SP_M, l_Q_SP_N, _
                wbz, wsz, l_Z_ERSTEZEILE, l_Z_SP_F, l_Z_SP_G, _
                fp(), fp_cnt, fn(), fn_cnt)
    
    '3.  Fertigmeldung und Protokoll ausgeben
     ->nicht gefundene Suchbegriffe
      If fn_cnt <> 0 Then
        s_tmp = Es wurden folgende Suchbegriffe vergeblich gesucht: & vbLf
        For x = 1 To fn_cnt
         ->auf 20 Meldungen begrenzen
          If x > 20 Then
            s_tmp = s_tmp & vbLf & und weitere ...
          Else
            s_tmp = s_tmp & fn(x)
          End If
        Next x
        MsgBox (s_tmp)
      End If
     ->gefundene Suchbegriffe
      If fp_cnt <> 0 Then
        s_tmp = Folgende Eintragungen wurden im Zielblatt durchgeführt: & vbLf
        For x = 1 To fp_cnt
         ->auf 20 Meldungen begrenzen
          If x > 20 Then
            s_tmp = s_tmp & vbLf & und weitere ...
          Else
            s_tmp = s_tmp & fp(x)
          End If
        Next x
      Else
        s_tmp = Es wurden keine Eintragungen im Zielblatt durchgeführt.
      End If
      MsgBox (s_tmp)
          
    Aufraeumen:
      On Error Resume Next
      Set wbz = Nothing: Set wsz = Nothing: Set wbq = Nothing: Set wsq = Nothing
      On Error GoTo 0
    End Sub
    '***********************************************************
    Private Function VergleichenUndUebertragen( _
                  wbq As Workbook, wsq As Worksheet, l_Q_ERSTEZEILE As Long, _
                  l_Q_SP_1 As Long, l_Q_SP_2 As Long, _
                  wbz As Workbook, wsz As Worksheet, l_Z_ERSTEZEILE As Long, _
                  l_Z_SP_1 As Long, l_Z_SP_2 As Long, _
                  fp() As String, fp_cnt As Long, fn() As String, fn_cnt As Long)
    '***********************************************************
      Dim d As Long, l_Z_SP As Long, l_Q_SP As Long, l_zRows As Long, z As Long
      Dim s_tmp As String, s As String, Zelle As Range, Zelle2 As Range
      Dim l_qrows As Long, r As Range, v_tmp As Variant, ersteAdresse As Variant
    
    '2   Auf dem Zielblatt werden die beiden relevanten Spalten untersucht.
    For d = 1 To 2
     ->relevante Spalten setzen
      If d = 1 Then
        l_Q_SP = l_Q_SP_1: l_Z_SP = l_Z_SP_1
      Else
        l_Q_SP = l_Q_SP_2: l_Z_SP = l_Z_SP_2
      End If
      
      l_zRows = wsz.Cells(wsz.Rows.Count, l_Z_SP).End(xlUp).Row
      For z = l_Z_ERSTEZEILE To l_zRows
        s_tmp = wsz.Cells(z, l_Z_SP).Value
    '2.1 Ist die Zelle nicht leer und
    '    der Inhalt hat als letztes Zeichen nicht eine Zahl
    '    ist dies der nächste Suchbegriff
        If s_tmp <>  Then
          s = Right(s_tmp, 1)
          Select Case s
            Case 0 To 9->nix machen, weil Zahl schon vorhanden
            Case Else
             ->Suchbegriff ist s_tmp
              
    '2.2 Suchbegriff in korrepondierender Spalte des Quellblattes suchen
    '    Wenn nicht gefunden -> nächste Zeile im Quellblatt untersuchen -> 2.1
              l_qrows = wsq.Cells(wsq.Rows.Count, l_Q_SP).End(xlUp).Row
              Set r = wsq.Range(wsq.Cells(l_Q_ERSTEZEILE, l_Q_SP), wsq.Cells(l_qrows, l_Q_SP))
              v_tmp = s_tmp
              Set Zelle = r.Find(v_tmp, LookIn:=xlValues, LookAt:=xlPart)
              If Not Zelle Is Nothing Then
                ersteAdresse = Zelle.Address
                Do
                  If Left(Zelle.Value, Len(s_tmp)) = s_tmp Then Exit Do
                  r.FindNext
                  If ersteAdresse = Zelle.Address Then
                   ->Suchbegriff nicht gefunden
                    Set Zelle = Nothing
                    Exit Do
                  End If
                Loop
              End If
              If Not Zelle Is Nothing Then
    '2.3 Inhalte der gefunden Zelle in Zielblatt kopieren
               ->Überprüfen, ob der Suchbegriff mehrmals vorhanden is
                Do
                  Set Zelle2 = r.Find(v_tmp, After:=Zelle, LookIn:=xlValues, LookAt:=xlPart)
                  If ersteAdresse = Zelle2.Address Then
                   ->Suchbegriff nicht nochmal gefunden
                    Set Zelle2 = Nothing: Exit Do
                  End If
                  If Left(Zelle2.Value, Len(s_tmp)) = s_tmp Then
                    If Zelle.Address = Zelle2.Address Then
                      Set Zelle2 = Nothing: Exit Do
                    Else
                      Exit Do
                    End If
                  End If
                Loop
    
                If Not Zelle2 Is Nothing Then
                 ->Suchbegriff ist mehrmals vorhanden
                  MsgBox ( _
                    Suchbegriff:  & v_tmp & vbLf & _
                    ist mehrfach in der Quelldatei vorhanden ! & vbLf & _
                    -> Abbruch)
                  GoTo Aufraeumen
                End If
                s_tmp = Zelle.Value
                wsz.Cells(z, l_Z_SP).Value = s_tmp
               ->gefundene Suchbegriff in Positiv-Liste
                fp_cnt = fp_cnt + 1: ReDim Preserve fp(1 To fp_cnt)
                fp(fp_cnt) = s_tmp
              Else
               ->nicht gefundene Suchbegriff in Negativ-Liste
                fn_cnt = fn_cnt + 1: ReDim Preserve fn(1 To fn_cnt)
                fn(fn_cnt) = s_tmp
              End If
          End Select
        End If
      Next z
    Next d
    Aufraeumen:
      On Error Resume Next
      Set r = Nothing: Set Zelle = Nothing: Set Zelle2 = Nothing
      On Error GoTo 0
    End Function
    '***********************************************************
    Private Function VoraussetzungZieldateiPruefen( _
              s_PfadDatei As String, wb As Workbook, ws As Worksheet) As Boolean
     ->False = Fehlerkennung, true=ok
     ->Rückgabe: wb - Zielarbeitsmappe, wsq - Zielarbeitsblatt
    '***********************************************************
      Dim b_gefunden As Boolean, w As Workbook
      
      VoraussetzungZieldateiPruefen = False->Fehlerkennung setzen
      
      b_gefunden = False
      For Each w In Workbooks
        If LCase(w.FullName) = LCase(s_PfadDatei) Then: Set wb = w: b_gefunden = True: Exit For
      Next
      If Not b_gefunden Then
        MsgBox (Zieldatei konnte nicht geöffnet werden & vbLf & _
                s_PfadDatei)
      Else
        wb.Activate
        Set ws = ActiveSheet
        VoraussetzungZieldateiPruefen = True->Fehlerkennung auf ok setzen
      End If
    Aufraeumen:
      On Error Resume Next: Set w = Nothing: On Error GoTo 0
    End Function
    '***********************************************************
    Private Function VoraussetzungQuelldateiPruefen( _
              s_PfadDatei As String, wb As Workbook, ws As Worksheet) As Boolean
     ->False = Fehlerkennung, true=ok
     ->Rückgabe: wb - Quellarbeitsmappe, wsq - Quellarbeitsblatt
    '***********************************************************
      Dim b_gefunden As Boolean, w As Workbook
      
      VoraussetzungQuelldateiPruefen = False->Fehlerkennung setzen
      
      b_gefunden = False
      For Each w In Workbooks
        If LCase(w.FullName) = LCase(s_PfadDatei) Then: Set wb = w: b_gefunden = True: Exit For
      Next
      If Not b_gefunden Then
        MsgBox (Quelldatei konnte nicht geöffnet werden & vbLf & _
                s_PfadDatei)
      Else
        If wb.Worksheets.Count <> 1 Then
          MsgBox ( _
            Quelldatei hat mehr als ein Arbeitsblatt. & vbLf & _
            -> Abbruch)
        Else
          Set ws = wb.Worksheets(1)
          VoraussetzungQuelldateiPruefen = True->Fehlerkennung auf ok setzen
        End If
      End If
    Aufraeumen:
      On Error Resume Next: Set w = Nothing: On Error GoTo 0
    End Function
     
  5. Hallo Matjes!!!!!! :) :) :eek: :eek:

    Das ist ja klasse, was du innerhalb kurzer Zeit auf die Beine gebracht hast!!! :D :eek: :eek:

    Wie geht das? Wie schafft man es so ein Makro zuschreiben? ::) Das ist ja Hexerei. ;)

    Ich hatte das ganze erst versucht mit der Makroaufzeichnung von Excel. Aber das hat überhaupt nicht hingehauen. :'(

    Also, zum Ergebnis: das meiste lief wunderbar. Es gibt noch ein, zwei Feinheiten, an denen man noch arbeiten muss.

    - Ich darf ja, wie es als Fehlermeldung auch angezeigt wurde, in der Quelldatei nicht mehr mehrere Sheets verwenden. Das ist aber nicht so schlimm. Das diente vorher nur der Übersichtlichkeit.

    - Ein Fehler bei der Ausführung aber war, dass er sich meist immer bei der gleichen Zelle aufhängte (Sanduhr wurde angezeigt: keine Rückmeldung)). Ich brach manuell ab (mit ESC), löschte den Inhalt aus der Zelle, mit der er anscheinend irgendwelche Problem hatte, provisorisch raus. Dann funktionierte das Makro wieder ganz normal und füllte die restlichen Felder weiter mit dem Inhalt aus der Quelldatei aus. Wenn man übrigens auf Debuggen ging, war im Code als Fehlermeldung der Befehl If ersteAdresse = Zelle2.Address Then gelb unterstrichen.

    - Ein weiterer Fehler war, dass er bei manchen Namen stockte, und als Fehler meldete, dass der Suchbegriff mehrfach in der Quelldatei vorhanden ist. Dazu muss ich sagen, dass sich bestimmte Namen sehr ähneln. Als provisorischen Lösungsweg habe ich die Namen ganz anders umbenannt, damit das funktionierte. Aber anscheinend kann das Makro Namen, die in der Quelldatei ähnlich klingen, wie Müller(F) und Müller(A), nicht unterscheiden. Offensichtlich fand er auch Namen wie Alex Wolf oder Wolf Peter (nur als Beispielnamen) identisch und gab eine Fehlermeldung hierüber aus. Wie sucht das Makro eigentlich nach identischen Namen in der Quelldatei, um sie in der Zieldatei mit dem neuen Wert zu überschreiben? Dann wüßte ich vielleicht eher, wie ich die gleichklingende Namen umbenenn sollte.

    Ansonsten war alles perfekt, jedenfalls ist mir nichts weiteres aufgefallen. Deshalb einen großen Lob für deine Leistung. :eek:

    Falls du einen alternativen Lösungsweg für die genannten Fehlermeldungen nennen könntest, wäre ich dir noch sehr dankbar.

    Vielen Vielen Dank!! :) :) :) :D :D
     
  6. Hi Der dankbare Gast  :D,
    mal schauen wie weit die Namensvariationen reichen  ;D

    Das mit dem Makro schreiben fängst Du schon ganz richtig an - erstmal aufzichnen und dann ggf. modifizieren. Dabei lernst Du die Sprache kennen. Dann gibt es halt irgendwann den Punkt, wo man mehr machen will, und dann helfen solche Beispiele mit konkreter Aufgabe. Das schwierigste ist eigentlich immer das logische Zerlegen - das Handwerkszeug findet sich dann.
    Ist wie bei einer fremden Sprache - irgendwann denkt man auch in dieser Sprache.


    Alle geänderten Passagen habe ich mit ### gekennzeichnet.

    zu
    Hab ich jetzt so geändert, daß die Quelldatei auch mehrere Blätter haen darf. Als Quellblatt wird das momentan aktive verwendet.

    zu
    Dieser Fall ist ein Bug gewesen - hab ich übersehen - ist jetzt gefixt  :D

    zu
    Dies ist das Suchproblem:
    Wenn in der Zieldatei nur->Müller' steht, findet er in der Quelldatei natürlich->Müller (A)',->Müller',->Müller (B)'.
    Das Problem ist der nicht eindeutige Suchbegriff. Visuell unterscheiden sich zwar->Müller' und->Müller (A)', aber vom Suchen sind sie nicht eindeutig - zumindest nicht mit diesem einfachen Suchen. Man könnte das lösen,  was ich aber an dieser Stelle zu aufwändig fände. Besser sind eindeutige Suchbegriffe.
    Die Fehlermeldung->mehrfach gefunden' hab ich um die Fundstellen und Inhalt erweitert.

    Wenn noch weitere Schwierigkeiten auftrete, melde dich.

    Gruß Matjes :)

    Code:
    '***********************************************************
    Sub QuelleZielAbgleichen()
    'Funktion:
    'Es werden Daten aus der Quelldatei in die Zieldatei übertragen
    '
    'Voraussetzung zum Aufruf des Makros:
    '- Quelldatei ist geöffnet und hat nur ein Arbeitsblatt
    '- Zieldatei ist geöffnet und das zu aktualisierende Arbeitsblatt ist aktiv
    '- die Suchbegriffe müssen eindeutig sein !!!
    '
    '1)  Voraussetzungen prüfen -> Bei Fehler Meldung + Abbruch
    '2   Auf dem Zielblatt werden die beiden relevanten Spalten untersucht.
    '2.1 Ist die Zelle nicht leer und
    '    der Inhalt hat als letztes Zeichen nicht eine Zahl
    '    ist dies der nächste Suchbegriff
    '2.2 Suchbegriff in korrepondierender Spalte des Quellblattes suchen
    '    Wenn nicht gefunden -> nächste Zeile im Quellblatt untersuchen -> 2.1
    '2.3 Inhalte der gefunden Zelle in Zielblatt kopieren
    '3.  Fertigmeldung und Protokoll ausgeben
    '***********************************************************
    
     ->### anpassen ###################################################
      Const s_QUELLDATEI As String = c:\download\QuelleTest.xls
      Const l_Q_ERSTEZEILE = 4   -> erste Zeile, ab der gesucht wird
                                 -> ab dieser Zeile folgen nur Wertezeilen
      Const l_Q_SP_M As Long = 13-> entspricht M
      Const l_Q_SP_N As Long = 14-> entspricht N
      
      Const s_ZIELDATEI As String = c:\download\ZielTest.xls
      Const l_Z_ERSTEZEILE = 3   -> erste Zeile, ab der gesucht wird
                                 -> ab dieser Zeile folgen nur Wertezeilen
      Const l_Z_SP_F As Long = 6 -> entspricht Spalte F
      Const l_Z_SP_G As Long = 7 -> entspricht Spalte G
     ->### anpassen Ende ##############################################
      
      Dim wbz As Workbook, wsz As Worksheet
      Dim wbq As Workbook, wsq As Worksheet
      Dim fp() As String, fp_cnt As Long->Merkfeld positives Suchergebnis
      Dim fn() As String, fn_cnt As Long->Merkfeld positives Suchergebnis
      Dim x As Long, s_tmp As String
      
     ->Merk-Felder initialisieren
      fp_cnt = 0: ReDim fp(1 To 1)
      fn_cnt = 0: ReDim fn(1 To 1)
      
    '1)  Voraussetzungen prüfen -> Bei Fehler Meldung + Abbruch
       
       'Hier wird das aktive Blatt der Quelldatei als wsq gesetzt
       If Not VoraussetzungQuelldateiPruefen2( _
                s_QUELLDATEI, wbq, wsq) Then GoTo Aufraeumen
     
     ->hier die Version, die nur ein Tabellenblatt zuläßt
     ->Jetzt auskommentiert ###
    '  If Not VoraussetzungQuelldateiPruefen( _
    '            s_QUELLDATEI, wbq, wsq) Then GoTo Aufraeumen
      
      If Not VoraussetzungZieldateiPruefen( _
                s_ZIELDATEI, wbz, wsz) Then GoTo Aufraeumen
       
      Call VergleichenUndUebertragen( _
                wbq, wsq, l_Q_ERSTEZEILE, l_Q_SP_M, l_Q_SP_N, _
                wbz, wsz, l_Z_ERSTEZEILE, l_Z_SP_F, l_Z_SP_G, _
                fp(), fp_cnt, fn(), fn_cnt)
    
    '3.  Fertigmeldung und Protokoll ausgeben
     ->nicht gefundene Suchbegriffe
      If fn_cnt <> 0 Then
        s_tmp = Es wurden folgende Suchbegriffe vergeblich gesucht: & vbLf
        For x = 1 To fn_cnt
         ->auf 20 Meldungen begrenzen
          If x > 20 Then
            s_tmp = s_tmp & vbLf & und weitere ...
          Else
            s_tmp = s_tmp & fn(x)
          End If
        Next x
        MsgBox (s_tmp)
      End If
     ->gefundene Suchbegriffe
      If fp_cnt <> 0 Then
        s_tmp = Folgende Eintragungen wurden im Zielblatt durchgeführt: & vbLf
        For x = 1 To fp_cnt
         ->auf 20 Meldungen begrenzen
          If x > 20 Then
            s_tmp = s_tmp & vbLf & und weitere ...
          Else
            s_tmp = s_tmp & fp(x)
          End If
        Next x
      Else
        s_tmp = Es wurden keine Eintragungen im Zielblatt durchgeführt.
      End If
      MsgBox (s_tmp)
          
    Aufraeumen:
      On Error Resume Next
      Set wbz = Nothing: Set wsz = Nothing: Set wbq = Nothing: Set wsq = Nothing
      On Error GoTo 0
    End Sub
    '***********************************************************
    Private Function VergleichenUndUebertragen( _
                  wbq As Workbook, wsq As Worksheet, l_Q_ERSTEZEILE As Long, _
                  l_Q_SP_1 As Long, l_Q_SP_2 As Long, _
                  wbz As Workbook, wsz As Worksheet, l_Z_ERSTEZEILE As Long, _
                  l_Z_SP_1 As Long, l_Z_SP_2 As Long, _
                  fp() As String, fp_cnt As Long, fn() As String, fn_cnt As Long)
    '***********************************************************
      Dim d As Long, l_Z_SP As Long, l_Q_SP As Long, l_zRows As Long, z As Long
      Dim s_tmp As String, s As String, Zelle As Range, Zelle2 As Range
      Dim l_qrows As Long, r As Range, v_tmp As Variant, ersteAdresse As Variant
    
    '2   Auf dem Zielblatt werden die beiden relevanten Spalten untersucht.
    For d = 1 To 2
     ->relevante Spalten setzen
      If d = 1 Then
        l_Q_SP = l_Q_SP_1: l_Z_SP = l_Z_SP_1
      Else
        l_Q_SP = l_Q_SP_2: l_Z_SP = l_Z_SP_2
      End If
      
      l_zRows = wsz.Cells(wsz.Rows.Count, l_Z_SP).End(xlUp).Row
      For z = l_Z_ERSTEZEILE To l_zRows
        s_tmp = wsz.Cells(z, l_Z_SP).Value
    '2.1 Ist die Zelle nicht leer und
    '    der Inhalt hat als letztes Zeichen nicht eine Zahl
    '    ist dies der nächste Suchbegriff
        If s_tmp <>  Then
          s = Right(s_tmp, 1)
          Select Case s
            Case 0 To 9->nix machen, weil Zahl schon vorhanden
            Case Else
             ->Suchbegriff ist s_tmp
              
    '2.2 Suchbegriff in korrepondierender Spalte des Quellblattes suchen
    '    Wenn nicht gefunden -> nächste Zeile im Quellblatt untersuchen -> 2.1
              l_qrows = wsq.Cells(wsq.Rows.Count, l_Q_SP).End(xlUp).Row
              Set r = wsq.Range(wsq.Cells(l_Q_ERSTEZEILE, l_Q_SP), wsq.Cells(l_qrows, l_Q_SP))
              v_tmp = s_tmp
              Set Zelle = r.Find(v_tmp, LookIn:=xlValues, LookAt:=xlPart)
              If Not Zelle Is Nothing Then
                ersteAdresse = Zelle.Address
                Do
                 ->### hier wird der gefundene Suchstring untersucht,
                 ->ob der Anfang des Inhalts der Quell-Zelle gleich
                 ->dem Suchstring ist
                  If Left(Zelle.Value, Len(s_tmp)) = s_tmp Then Exit Do
                  r.FindNext
                  If ersteAdresse = Zelle.Address Then
                   ->Suchbegriff nicht gefunden
                    Set Zelle = Nothing
                    Exit Do
                  End If
                Loop
              End If
              If Not Zelle Is Nothing Then
    '2.3 Inhalte der gefunden Zelle in Zielblatt kopieren
               ->Überprüfen, ob der Suchbegriff mehrmals vorhanden is
                Do
                  Set Zelle2 = r.Find(v_tmp, After:=Zelle, LookIn:=xlValues, LookAt:=xlPart)
                 ->sicherheitshalber abfragen ###
                  If Zelle2 Is Nothing Then Exit Do
                  If ersteAdresse = Zelle2.Address Then
                   ->Suchbegriff nicht nochmal gefunden
                    Set Zelle2 = Nothing: Exit Do
                  End If
                 ->### hier wird der gefundene Suchstring untersucht,
                 ->ob der Anfang des Inhalts der Quell-Zelle gleich
                 ->dem Suchstring ist
                  If Left(Zelle2.Value, Len(s_tmp)) = s_tmp Then
                    If Zelle.Address = Zelle2.Address Then
                      Set Zelle2 = Nothing: Exit Do
                    Else
                      Exit Do
                    End If
                  End If
                Loop
    
                If Not Zelle2 Is Nothing Then
                 ->Suchbegriff ist mehrmals vorhanden
                 ->### erweitert
                  wsq.Activate
                  MsgBox ( _
                    Suchbegriff:  & v_tmp & vbLf & _
                    ist mehrfach in der Quelldatei vorhanden ! & vbLf & _
                    1. Fundstelle:  & Zelle.Address & _
                      Inhalt:  & Zelle.Value & vbLf & _
                    2. Fundstelle:  & Zelle2.Address & _
                      Inhalt:  & Zelle2.Value & vbLf & _
                    -> Abbruch)
                  GoTo Aufraeumen
                End If
                s_tmp = Zelle.Value
                wsz.Cells(z, l_Z_SP).Value = s_tmp
               ->gefundene Suchbegriff in Positiv-Liste
                fp_cnt = fp_cnt + 1: ReDim Preserve fp(1 To fp_cnt)
                fp(fp_cnt) = s_tmp
              Else
               ->nicht gefundene Suchbegriff in Negativ-Liste
                fn_cnt = fn_cnt + 1: ReDim Preserve fn(1 To fn_cnt)
                fn(fn_cnt) = s_tmp
              End If
          End Select
        End If
      Next z
    Next d
    Aufraeumen:
      On Error Resume Next
      Set r = Nothing: Set Zelle = Nothing: Set Zelle2 = Nothing
      On Error GoTo 0
    End Function
    '***********************************************************
    Private Function VoraussetzungZieldateiPruefen( _
              s_PfadDatei As String, wb As Workbook, ws As Worksheet) As Boolean
     ->False = Fehlerkennung, true=ok
     ->Rückgabe: wb - Zielarbeitsmappe, wsq - Zielarbeitsblatt
    '***********************************************************
      Dim b_gefunden As Boolean, w As Workbook
      
      VoraussetzungZieldateiPruefen = False->Fehlerkennung setzen
      
      b_gefunden = False
      For Each w In Workbooks
        If LCase(w.FullName) = LCase(s_PfadDatei) Then: Set wb = w: b_gefunden = True: Exit For
      Next
      If Not b_gefunden Then
        MsgBox (Zieldatei konnte nicht geöffnet werden & vbLf & _
                s_PfadDatei)
      Else
        wb.Activate
        Set ws = ActiveSheet
        VoraussetzungZieldateiPruefen = True->Fehlerkennung auf ok setzen
      End If
    Aufraeumen:
      On Error Resume Next: Set w = Nothing: On Error GoTo 0
    End Function
    '***********************************************************
    Private Function VoraussetzungQuelldateiPruefen( _
              s_PfadDatei As String, wb As Workbook, ws As Worksheet) As Boolean
     ->False = Fehlerkennung, true=ok
     ->Rückgabe: wb - Quellarbeitsmappe, wsq - Quellarbeitsblatt
    '***********************************************************
      Dim b_gefunden As Boolean, w As Workbook
      
      VoraussetzungQuelldateiPruefen = False->Fehlerkennung setzen
      
      b_gefunden = False
      For Each w In Workbooks
        If LCase(w.FullName) = LCase(s_PfadDatei) Then: Set wb = w: b_gefunden = True: Exit For
      Next
      If Not b_gefunden Then
        MsgBox (Quelldatei konnte nicht geöffnet werden & vbLf & _
                s_PfadDatei)
      Else
        If wb.Worksheets.Count <> 1 Then
          MsgBox ( _
            Quelldatei hat mehr als ein Arbeitsblatt. & vbLf & _
            -> Abbruch)
        Else
          Set ws = wb.Worksheets(1)
          VoraussetzungQuelldateiPruefen = True->Fehlerkennung auf ok setzen
        End If
      End If
    Aufraeumen:
      On Error Resume Next: Set w = Nothing: On Error GoTo 0
    End Function
    
    '***********************************************************
    '### neu
    Private Function VoraussetzungQuelldateiPruefen2( _
              s_PfadDatei As String, wb As Workbook, ws As Worksheet) As Boolean
     ->False = Fehlerkennung, true=ok
     ->Rückgabe: wb - Quellarbeitsmappe, wsq - Quellarbeitsblatt
    '***********************************************************
      Dim b_gefunden As Boolean, w As Workbook
      
      VoraussetzungQuelldateiPruefen2 = False->Fehlerkennung setzen
      
      b_gefunden = False
      For Each w In Workbooks
        If LCase(w.FullName) = LCase(s_PfadDatei) Then: Set wb = w: b_gefunden = True: Exit For
      Next
      If Not b_gefunden Then
        MsgBox (Quelldatei konnte nicht geöffnet werden & vbLf & _
                s_PfadDatei)
      Else
       ->aktives Blatt setzen ###
        wb.Activate
        Set ws = ActiveSheet
        VoraussetzungQuelldateiPruefen2 = True->Fehlerkennung auf ok setzen
      End If
    Aufraeumen:
      On Error Resume Next: Set w = Nothing: On Error GoTo 0
    End Function
     
  7. Ola und n.B.

    eine ordentliche Registrierung samt gültiger Mailadresse statt der kreativen Ersatzmails sollte die Mühe auch einem Gast wert sein ...
     
  8. Hallo Matjes, :D :D

    die Überarbeitung ist perfekt :) :). Makro funktionierte ohne Probleme (mit und ohne Sheets). Ein Fehler ist mir nicht aufgefallen. :D

    Nachdem ich das Makro benutzte, habe ich übrigens die eingefügten Inhalte stichprobenartig genauer angeschaut und mit denen in der Quelldatei verglichen. Nnur der Sicherheit halber um zu vermeiden, dass bei gleichklingenden Namen der falsche Wert eingefügt wird. Aber es war nichts zu beanstanden. :D

    Ich weiß gar nicht, wie ich dir danken soll. Wenn du wüßtest, wieviel Arbeit du mir erspart hast. ;)

    Und das ist so klasse zu sehen, wie einem hunderte von Arbeitsschritten erspart werden.

    ps:
    Sorry an den Moderator PCDjoe. Habe keine Mailadresse angegeben, um nicht Opfer von Spam-Mails zu werden.
     
  9. Hi Memis,

    schön das es geklappt hat  :D (jetzt auch mit dem Namen  ;D ).

    Vielleicht schaust Du ab und an mal vorbei (in der Zeit, die Du gespart hast) und hilfst dann anderen. Das ist Sinn und Zweck dieses Forums.

    Wenn Du dich nach einigem Schnuppern hier im Forum wohl fühlst, steht dir der Weg zu einer Mitgliedschaft offen. Damit würdest Du den Betrieb dieses Forums unterstützen.

    Wegen der mail-Adresse hatte ich übrigens noch nie Probleme.

    Gruß Matjes  ;)

    ps: Frage an den Moderator: Kann die mail-Adresse durch Robots ausgelesen werden ?
     
  10. Hi,

    ja, allerdings wenn man registriert ist nicht mehr, da hat man die Option die E-Mail Adresse nicht anzeigen zu lassen (Außer Moderatoren :) ).
     
Die Seite wird geladen...

Frage bei einem Makro - Ähnliche Themen

Forum Datum
Fragen zu einem Icon Windows 7 Forum 7. Okt. 2014
Frage zu einem Netzteil für einen Notebook Windows XP Forum 29. Aug. 2012
Guter PHP-Editor & Frage zu einem HTML-Code Webentwicklung, Hosting & Programmierung 10. Juli 2007
Bootfrage trotz nur einem System Treiber & BIOS / UEFI 29. Mai 2007
Frage aus reinem Interesse Windows XP Forum 21. Feb. 2007