'***********************************************************
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
