Option Explicit
Private Const c_KENNUNGLAND_CH = CH
Private Const c_KENNUNGLAND_D = DE
Private Const c_KENNUNG_EINS = 1
Private Const cQ_DATEINAME = Adressen.xls ->Dateiname der zu sortierenden Datei (Quelle)
Private Const cQ_BLTNAME = Adressen ->Blattname (Quelle)
Private Const cQ_ZUEBERSCHR = 1 ->Überschriften-Zeile
Private Const cQ_ZERSTEW = 2 ->erste Wertezeile
Private Const cQ_SP_LAND = 8 ->Spalte H mit Länderkennung
Private Const cQ_SP_EINS = 12 ->Spalte L mit Kennung 1
Private Const cQ_SP_N = 14 ->Spalte, die immer gefüllt ist - zur Bestimmung der letzten Zeile
Private Const cZ_DATEINAME = Adressen_sortiert.xls->Dateiname der zu sortierenden Datei (Ziel)
Private Const cZ_BLTNAME_TEIL_1 = Adressen_ ->Vorlage Blattname, Länderkennung wird eingefügt
Private Const cZ_BLTNAME_TEIL_2 = _1
Private Const cBLTNAME_TMP = ___TEMP___ ->temporäres Blatt in der Zieldatei
'**********************************************************************************************
Sub AdrCHundDsortiert()
Dim wbq As Workbook, wsq As Worksheet, wbz As Workbook, wsz As Worksheet
If Not QuelldateiUndBlattBestimmen(cQ_DATEINAME, wbq, cQ_BLTNAME, wsq) Then GoTo AUFRAEUMEN
If Not ZieldateiVorbereiten(wbq.Path, cZ_DATEINAME, wbz, cBLTNAME_TMP) Then GoTo AUFRAEUMEN
->Quellblatt als CH-Blatt und DE-Blatt in Zieldatei kopieren
wsq.Copy After:=wbz.Worksheets(1)
wbz.Worksheets(2).Name = c_KENNUNGLAND_D
wsq.Copy After:=wbz.Worksheets(1)
wbz.Worksheets(2).Name = c_KENNUNGLAND_CH
->Temporäres Blatt in Zieldatei löschen
Application.DisplayAlerts = False
wbz.Worksheets(cBLTNAME_TMP).Delete
Application.DisplayAlerts = True
->Für alle Blätter in der Zieldatei
For Each wsz In wbz.Worksheets
->alle Sätze außer der Länderkennung / 1 auf dem Blatt löschen
Call NurLaenderkennungMitEinsStehenLassen(wsz)->Ländrkennung = Blattname
->Endgueltiger Blattname z.B. Adresse_DE_1
wsz.Name = cZ_BLTNAME_TEIL_1 & wsz.Name & cZ_BLTNAME_TEIL_2
Next
AUFRAEUMEN:
Set wbq = Nothing: Set wsq = Nothing
End Sub
'**********************************************************************************************
Private Function NurLaenderkennungMitEinsStehenLassen(ws As Worksheet)
Dim r As Range
Dim sLaenderkennung As String
Dim lRows As Long
Dim Suchbegriff As Variant
sLaenderkennung = ws.Name->Blattname ist Länderkennung
->letzte Zeile bestimmen
lRows = ws.Cells(ws.Rows.Count, cQ_SP_N).End(xlUp).Row
->keine Zeilen vorhanden -> Ende der Bearbeitung
If lRows < cQ_ZERSTEW Then GoTo AUFRAEUMEN->wenn
->Wenn mehr als eine Zeile vorhanden ist sortieren Länderkennung und 1
If lRows > cQ_ZERSTEW Then
ws.Rows(cQ_ZERSTEW & : & lRows).Sort _
Key1:=ws.Cells(cQ_ZERSTEW, cQ_SP_LAND), Order1:=xlAscending, _
Key2:=ws.Cells(cQ_ZERSTEW, cQ_SP_EINS), Order2:=xlAscending, _
Header:=xlNo
End If
Suchbegriff = sLaenderkennung
Call AlleZeilenOhneSuchbegriffLoeschen(ws, Suchbegriff, cQ_SP_LAND, cQ_ZERSTEW, cQ_SP_N)
Suchbegriff = 1
Call AlleZeilenOhneSuchbegriffLoeschen(ws, Suchbegriff, cQ_SP_EINS, cQ_ZERSTEW, cQ_SP_N)
AUFRAEUMEN:
Set r = Nothing
End Function
'**********************************************************************************************
Private Function QuelldateiUndBlattBestimmen(sDateiname As String, _
wb As Workbook, _
sBlattname As String, _
ws As Worksheet) As Boolean
->Quelldatei muß geöffnet sein, sonst -> Fehler
On Error Resume Next
Set wb = Nothing
Set wb = Workbooks(sDateiname)
On Error GoTo 0
If wb Is Nothing Then
MsgBox Quelldatei & sDateiname & ist nicht geöffnet.
GoTo AUFRAEUMEN
End If
->Quellblatt setzen
On Error Resume Next
Set ws = Nothing
Set ws = wb.Worksheets(sBlattname)
On Error GoTo 0
If ws Is Nothing Then
MsgBox In Quelldatei & wb.Name & ist das Blatt & sBlattname & nicht vorhanden.
GoTo AUFRAEUMEN
End If
QuelldateiUndBlattBestimmen = True->Rückgabekennung OK
AUFRAEUMEN:
End Function
'**********************************************************************************************
Private Function ZieldateiVorbereiten(sPfad As String, _
sDateiname As String, _
wb As Workbook, _
sBlattname_tmp As String) As Boolean
Dim x As Long
->Zieldatedatei existiert ?
If Dir(sPfad & Application.PathSeparator & sDateiname, vbNormal) = Then
->Datei nicht vorhanden -> neu anlegen
Set wb = Workbooks.Add
Application.DisplayAlerts = False
For x = wb.Worksheets.Count To 2 Step -1
wb.Worksheets(x).Delete
Next
Application.DisplayAlerts = True
->einziges Blatt wird temporäres blatt
wb.Worksheets(1).Name = sBlattname_tmp
wb.SaveAs Filename:=sPfad & Application.PathSeparator & sDateiname
Else
->Datei vorhanden
->offen ?
On Error Resume Next
Set wb = Nothing
Set wb = Workbooks(sDateiname)
On Error GoTo 0
If wb Is Nothing Then
->noch nicht offen -> öffnen
On Error Resume Next
Set wb = Workbooks.Open(sPfad & Application.PathSeparator & sDateiname)
On Error GoTo 0
If wb Is Nothing Then
MsgBox Zieldatei & sPfad & Application.PathSeparator & sDateiname & kann nicht geöffnet werden.
GoTo AUFRAEUMEN
End If
End If
->alle Blätter bis auf das letzte löschen
Application.DisplayAlerts = False
For x = wb.Worksheets.Count To 2 Step -1
wb.Worksheets(x).Delete
Next
Application.DisplayAlerts = True
->einziges Blatt wird temporäres blatt
wb.Worksheets(1).Name = sBlattname_tmp
End If
ZieldateiVorbereiten = True->Rückgabekennung OK
AUFRAEUMEN:
End Function
'**********************************************************************************************
Private Function AlleZeilenOhneSuchbegriffLoeschen(ws As Worksheet, _
Suchbegriff As Variant, _
InSpalt As Long, _
abZeile As Long, _
LetzteZeileAusSpalte As Long)
Dim r As Range, Zelle As Range
Dim lRows As Long
->letzte Zeile bestimmen
lRows = ws.Cells(ws.Rows.Count, LetzteZeileAusSpalte).End(xlUp).Row
->keine Zeilen vorhanden -> Ende der Bearbeitung
If lRows < abZeile Then GoTo AUFRAEUMEN->wenn
->letzte Zeile mit Länderkennung suchen
Set Zelle = Nothing
Set r = ws.Range(ws.Cells(abZeile, InSpalt), ws.Cells(lRows, InSpalt))
Set Zelle = r.Find( _
What:=Suchbegriff, _
After:=ws.Cells(abZeile, InSpalt), _
Lookat:=xlWhole, _
SearchDirection:=xlPrevious)
->Nach dem Fundort bis zum Ende Zeilen löschen
If Zelle Is Nothing Then
->keine Länderkennung gefunden -> alle Zeilen löschen
ws.Rows(abZeile & : & lRows).Delete
ElseIf Zelle.Row = lRows Then
->letzte Zeile -> nix machen
Else
->gefunden
ws.Rows((Zelle.Row + 1) & : & lRows).Delete
End If
->------------------
->letzte Zeile bestimmen
lRows = ws.Cells(ws.Rows.Count, LetzteZeileAusSpalte).End(xlUp).Row
->keine Zeilen vorhanden -> Ende der Bearbeitung
If lRows < abZeile Then GoTo AUFRAEUMEN->wenn
->erste Zeile mit Länderkennung suchen
Set Zelle = Nothing
Set r = ws.Range(ws.Cells(abZeile, InSpalt), ws.Cells(lRows, InSpalt))
Set Zelle = r.Find( _
What:=Suchbegriff, _
After:=ws.Cells(lRows, InSpalt), _
Lookat:=xlWhole, _
SearchDirection:=xlNext)
->Vor dem Fundort bis zum Anfang Zeilen löschen
If Zelle.Row = abZeile Then
->erste Zeile -> nix machen
Else
->gefunden
ws.Rows(abZeile & : & (Zelle.Row - 1)).Delete
End If
AUFRAEUMEN:
Set r = Nothing: Set Zelle = Nothing
End Function
