Frage bei einem Makro

  • #21
nee, leider nicht ::). Manchmal sind es mehr, manchmal weniger. Je nachdem wie lang die Namen sind. Sorry :-[
 
  • #22
Hi Memis,

ich hab eine Funktion eingebaut, die den Namen selektieren kann, entsprechend deinem Beispiel. Schau mal ob das deine Ansprüche erfüllt.
Wenn noch andere Zeichen in den Zahlen enthalten sind, kommt eine entsprechende Fehlermeldung und wir können damit die Funktion->NamenSelektieren' korrigieren.

Gruß Matjes :)

einmal das komplette Makro (sind mehrere Änderungen enthalten):
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_name 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
'    (letztes Zeichen <> Zahl -> Suchbegriff) oder
'    (letztes Zeichen =  Zahl: 3 Zahlen abschneiden ->  Suchbegriff
    If NamenSelektieren(s_tmp, s_name) Then
        s_tmp = s_name
    
'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
           ->Wenn Quelle und Ziel ungleich
            If Zelle.Value <> wsz.Cells(z, l_Z_SP).Value Then
              wsz.Cells(z, l_Z_SP).Value = Zelle.Value
             ->gefundene Suchbegriff in Positiv-Liste
              fp_cnt = fp_cnt + 1: ReDim Preserve fp(1 To fp_cnt)
              fp(fp_cnt) = s_tmp
            End If
          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 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

'***********************************************************
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
    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
'******************************************************
Private Function NamenSelektieren(s_vollerString As String, s_name As String) As Boolean
'Beispiel für das Format:
'Müller, F.      19.10      12-2-9     8-3-1
'Rückgabe:Müller, F.
'true: ok -> s_name enthält den Namen
'false:Fehler
'******************************************************
  Dim s As String, Stufe As Long, x As Long
  
  NamenSelektieren = False
  If s_vollerString =  Then s_name = : Exit Function

 ->Prüfen, ob Zahl am Ende. Nein-> Name ist voller String
  s = Right(s_vollerString, 1)
  Select Case s
    Case 0 To 9
    Case Else
      s_name = s_vollerString
      NamenSelektieren = True
      Exit Function
  End Select
      
 ->Über alle Zeichen rückwärts
  s_name = 
  Stufe = 0-> Kennzeichen erste Zahl
  For x = Len(s_vollerString) To 1 Step -1
    s = Mid(s_vollerString, x, 1)->nächstes Zeichen
    
    If Stufe = 0 Then->letzte Zahl ?
      Select Case s
        Case 0 To 9, -     'zulässig für letzte Zahl
        Case  : Stufe = Stufe + 1->Leerzeichen auf nächste Stufe schalten
        Case Else->unzulässig
          MsgBox ( _
            Unzulässiges Zeichen-> & s &-> an Position  & x & vbLf & _
             in-> & s_vollerString &->)
          Exit Function
      End Select
    ElseIf Stufe = 1 Then->Leerzeichen vor letzte Zahl ?
      Select Case s
        Case       'zulässig für Leerzeichen vor letzter Zahl
        Case 0 To 9: Stufe = Stufe + 1->Zahl -> auf nächste Stufe schalten
        Case Else->unzulässig
          MsgBox ( _
            Unzulässiges Zeichen-> & s &-> an Position  & x & vbLf & _
             in-> & s_vollerString &->)
          Exit Function
      End Select
    ElseIf Stufe = 2 Then->vorletzte Zahl ?
      Select Case s
        Case 0 To 9, -     'zulässig für vorletzte Zahl
        Case  : Stufe = Stufe + 1->Leerzeichen auf nächste Stufe schalten
        Case Else->unzulässig
          MsgBox ( _
            Unzulässiges Zeichen-> & s &-> an Position  & x & vbLf & _
             in-> & s_vollerString &->)
          Exit Function
      End Select
    ElseIf Stufe = 3 Then->Leerzeichen vor vorletzter Zahl ?
      Select Case s
        Case       'zulässig für Leerzeichen vor vorletzter Zahl
        Case 0 To 9: Stufe = Stufe + 1->Zahl -> auf nächste Stufe schalten
        Case Else->unzulässig
          MsgBox ( _
            Unzulässiges Zeichen-> & s &-> an Position  & x & vbLf & _
             in-> & s_vollerString &->)
          Exit Function
      End Select
    ElseIf Stufe = 4 Then->erste Zahl ?
      Select Case s
        Case 0 To 9, .     'zulässig für erste Zahl
        Case  : Stufe = Stufe + 1->Leerzeichen auf nächste Stufe schalten
        Case Else->unzulässig
          MsgBox ( _
            Unzulässiges Zeichen-> & s &-> an Position  & x & vbLf & _
             in-> & s_vollerString &->)
          Exit Function
      End Select
    ElseIf Stufe = 5 Then->Leerzeichen vor erster Zahl ?
      Select Case s
        Case       'zulässig für Leerzeichen vor erster Zahl
        Case Else->Name erreicht
          s_name = Mid(s_vollerString, 1, x)
          NamenSelektieren = True
          Exit Function
      End Select
    End If
  Next
End Function
 
  • #23
Hui :D :D :D :D :D :D

Habe ich gerade ausprobiert! ;D

Scheint perfekt zu funktionieren :D :D :D.

Du bist wunderbar! ;) :) ;) :) :) :)

Wie hast du das geschafft?

Der Makro hat vorher schon die Daten in der Art Name 22.40 5-4-3 6-2-0 aktualisiert. Wenn ich dann zum testen ein paar Daten in der Quelldatei geändert habe (z.B. Name 24.35 8-4-3 6-2-1), wurden die Daten - nachdem ich dein startete - aktualisiert. :eek: :eek: :eek:

Wonach richtet sich dein Code bei der erneuten Suche, ob irgendwelche neuen Daten für die bereits eingetragenen Daten vorliegen? Ich möchte das nur wissen, damit ich weiß, worauf ich (bei den Namen oder Zahlenreihen) achten muss.


Memis
 
  • #24
Hi memis,

noch eine Korrekturversion. Die hält jetzt auch Müller, F und Müller, Franz auseinander.

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 & vbLf & 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_name As String, Zelle As Range, Zelle2 As Range
  Dim l_qrows As Long, r As Range, v_tmp As Variant, ersteAdresse As Variant
  Dim s_vollerStringQuelle As String

'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
'    (letztes Zeichen <> Zahl -> Suchbegriff) oder
'    (letztes Zeichen =  Zahl: 3 Zahlen abschneiden ->  Suchbegriff
    If NamenSelektieren(s_tmp, s_name) Then
        s_tmp = s_name
    
'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 enthaltene Name gleich dem Suchstring ist
              s_vollerStringQuelle = Zelle.Value
              If NamenSelektieren(s_vollerStringQuelle, s_name) Then
                If s_name = s_tmp Then Exit Do
              End If
              Set Zelle = r.Find(v_tmp, After:=Zelle, LookIn:=xlValues, LookAt:=xlPart)
              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
            Set Zelle2 = Zelle
            Do
              Set Zelle2 = r.Find(v_tmp, After:=Zelle2, 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 enthaltene Name gleich dem Suchstring ist
              s_vollerStringQuelle = Zelle2.Value
              If NamenSelektieren(s_vollerStringQuelle, s_name) Then
                If s_name = s_tmp Then
                  If Zelle.Address = Zelle2.Address Then
                    Set Zelle2 = Nothing: Exit Do
                  Else
                    Exit Do
                  End If
                End If
              End If
            Loop

            If Not Zelle2 Is Nothing Then
             ->Suchbegriff ist mehrmals vorhanden
              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
           ->Wenn Quelle und Ziel ungleich
            If Zelle.Value <> wsz.Cells(z, l_Z_SP).Value Then
              wsz.Cells(z, l_Z_SP).Value = Zelle.Value
             ->gefundene Suchbegriff in Positiv-Liste
              fp_cnt = fp_cnt + 1: ReDim Preserve fp(1 To fp_cnt)
              fp(fp_cnt) = s_tmp
            End If
          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 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

'***********************************************************
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
    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
Private Function NamenSelektieren(s_vollerString As String, s_name As String) As Boolean
'Beispiel für das Format:
'Müller, F.      19.10      12-2-9     8-3-1
'Rückgabe:Müller, F.
'true: ok -> s_name enthält den Namen
'false:Fehler
'******************************************************
  Dim s As String, Stufe As Long, x As Long
  
  NamenSelektieren = False
  If s_vollerString =  Then s_name = : Exit Function
  
  Do While Mid(s_vollerString, Len(s_vollerString), 1) =  
    s_vollerString = Left(s_vollerString, Len(s_vollerString) - 1)
  Loop
  
 ->Prüfen, ob Zahl am Ende. Nein-> Name ist voller String
  s = Right(s_vollerString, 1)
  Select Case s
    Case 0 To 9
    Case Else
      s_name = s_vollerString
      NamenSelektieren = True
      Exit Function
  End Select
      
 ->Über alle Zeichen rückwärts
  s_name = 
  Stufe = 0-> Kennzeichen erste Zahl
  For x = Len(s_vollerString) To 1 Step -1
    s = Mid(s_vollerString, x, 1)->nächstes Zeichen
    
    If Stufe = 0 Then->letzte Zahl ?
      Select Case s
        Case 0 To 9, -     'zulässig für letzte Zahl
        Case  : Stufe = Stufe + 1->Leerzeichen auf nächste Stufe schalten
        Case Else->unzulässig
          MsgBox ( _
            Unzulässiges Zeichen-> & s &-> an Position  & x & vbLf & _
             in-> & s_vollerString &->)
          Exit Function
      End Select
    ElseIf Stufe = 1 Then->Leerzeichen vor letzte Zahl ?
      Select Case s
        Case       'zulässig für Leerzeichen vor letzter Zahl
        Case 0 To 9: Stufe = Stufe + 1->Zahl -> auf nächste Stufe schalten
        Case Else->unzulässig
          MsgBox ( _
            Unzulässiges Zeichen-> & s &-> an Position  & x & vbLf & _
             in-> & s_vollerString &->)
          Exit Function
      End Select
    ElseIf Stufe = 2 Then->vorletzte Zahl ?
      Select Case s
        Case 0 To 9, -     'zulässig für vorletzte Zahl
        Case  : Stufe = Stufe + 1->Leerzeichen auf nächste Stufe schalten
        Case Else->unzulässig
          MsgBox ( _
            Unzulässiges Zeichen-> & s &-> an Position  & x & vbLf & _
             in-> & s_vollerString &->)
          Exit Function
      End Select
    ElseIf Stufe = 3 Then->Leerzeichen vor vorletzter Zahl ?
      Select Case s
        Case       'zulässig für Leerzeichen vor vorletzter Zahl
        Case 0 To 9: Stufe = Stufe + 1->Zahl -> auf nächste Stufe schalten
        Case Else->unzulässig
          MsgBox ( _
            Unzulässiges Zeichen-> & s &-> an Position  & x & vbLf & _
             in-> & s_vollerString &->)
          Exit Function
      End Select
    ElseIf Stufe = 4 Then->erste Zahl ?
      Select Case s
        Case 0 To 9, .     'zulässig für erste Zahl
        Case  : Stufe = Stufe + 1->Leerzeichen auf nächste Stufe schalten
        Case Else->unzulässig
          MsgBox ( _
            Unzulässiges Zeichen-> & s &-> an Position  & x & vbLf & _
             in-> & s_vollerString &->)
          Exit Function
      End Select
    ElseIf Stufe = 5 Then->Leerzeichen vor erster Zahl ?
      Select Case s
        Case       'zulässig für Leerzeichen vor erster Zahl
        Case Else->Name erreicht
          s_name = Mid(s_vollerString, 1, x)
          NamenSelektieren = True
          Exit Function
      End Select
    End If
  Next
End Function
 
  • #25
Matjes ist super!

:D :D :D :D :D :D :D :D :D :D :D :D :D :D :D
 
Thema:

Frage bei einem Makro

ANGEBOTE & SPONSOREN

Neueste Themen

Statistik des Forums

Themen
113.838
Beiträge
707.961
Mitglieder
51.491
Neuestes Mitglied
haraldmuc
Oben