AW: Probleme beim sortieren....
16.09.2008 14:27:15
Gordon
Ok,
habe mal die Datensatzdatei hochgeladen: https://www.herber.de/bbs/user/55434.zip
Die andere Datei, wo das Makro enthalten ist, konnte ich leider nicht hochladen, da diese zu groß war. Dafür hier nun der ganze Quellcode des Makros:
Option Explicit
Sub Listen()
Dim i As Long, Anzahl As Long
Dim Datei As String, foo As String
Dim VZ$
Dim lngG As Long, lngT As Long, strAG As String, strN As String
Dim wksT As Worksheet
Application.DisplayAlerts = False
Application.EnableEvents = False
'Dateiname bestimmen
Datei = Worksheets("Listen erstellen").Range("e6").Value
If Worksheets("Listen erstellen").Range("e6").Value = "" Then
Datei = "Listengenerator_Original.xls"
End If
'Dateinnamen öffnen
Workbooks.Open Filename:=ThisWorkbook.Path & "\" & Datei, ReadOnly:=True
ActiveWorkbook.Sheets("Tabelle1").Range("A3:N10002").Sort Key1:=Range("M3"), Order1:= _
xlAscending, Key2:=Range("N3"), Order2:=xlAscending, Key3:=Range("A3"), Order3:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
'Daten vom Original zum Generator übertragen
ThisWorkbook.Sheets("Generator").Range("a1:a10000").Value = ActiveWorkbook.Sheets("Tabelle1"). _
Range("a3:a10002").Value
ThisWorkbook.Sheets("Generator").Range("b1:b10000").Value = ActiveWorkbook.Sheets("Tabelle1"). _
Range("b3:b10002").Value
ThisWorkbook.Sheets("Generator").Range("c1:c10000").Value = ActiveWorkbook.Sheets("Tabelle1"). _
Range("c3:c10002").Value
ThisWorkbook.Sheets("Generator").Range("d1:d10000").Value = ActiveWorkbook.Sheets("Tabelle1"). _
Range("d3:d10002").Value
ThisWorkbook.Sheets("Generator").Range("e1:e10000").Value = ActiveWorkbook.Sheets("Tabelle1"). _
Range("e3:e10002").Value
ThisWorkbook.Sheets("Generator").Range("j1:j10000").Value = ActiveWorkbook.Sheets("Tabelle1"). _
Range("f3:f10002").Value
ThisWorkbook.Sheets("Generator").Range("k1:k10000").Value = ActiveWorkbook.Sheets("Tabelle1"). _
Range("g3:g10002").Value
ThisWorkbook.Sheets("Generator").Range("l1:l10000").Value = ActiveWorkbook.Sheets("Tabelle1"). _
Range("h3:h10002").Value
ThisWorkbook.Sheets("Generator").Range("m1:m10000").Value = ActiveWorkbook.Sheets("Tabelle1"). _
Range("i3:i10002").Value
ThisWorkbook.Sheets("Generator").Range("n1:n10000").Value = ActiveWorkbook.Sheets("Tabelle1"). _
Range("j3:j10002").Value
ThisWorkbook.Sheets("Generator").Range("o1:o10000").Value = ActiveWorkbook.Sheets("Tabelle1"). _
Range("k3:k10002").Value
foo = ActiveWorkbook.Sheets("Tabelle1").Range("L2").Value
If foo = "Leistungsbereichs-Nr." Or foo = "Leistungsbereichs-Nummer" Or foo = " _
Leistungsbereichsnummer" Or foo = "Leistungsbereichsnr." Then
ThisWorkbook.Sheets("Generator").Range("p1:p10000").Value = ActiveWorkbook.Sheets("Tabelle1"). _
Range("l3:l10002").Value
ThisWorkbook.Sheets("Generator").Range("q1:q10000").Value = ActiveWorkbook.Sheets("Tabelle1"). _
Range("m3:m10002").Value
ThisWorkbook.Sheets("Generator").Range("r1:r10000").Value = ActiveWorkbook.Sheets("Tabelle1"). _
Range("n3:n10002").Value
ThisWorkbook.Sheets("Generator").Range("s1:s10000").Value = ActiveWorkbook.Sheets("Tabelle1"). _
Range("o3:o10002").Value
Else
ThisWorkbook.Sheets("Generator").Range("q1:q10000").Value = ActiveWorkbook.Sheets("Tabelle1"). _
Range("l3:l10002").Value
ThisWorkbook.Sheets("Generator").Range("r1:r10000").Value = ActiveWorkbook.Sheets("Tabelle1"). _
Range("m3:m10002").Value
ThisWorkbook.Sheets("Generator").Range("s1:s10000").Value = ActiveWorkbook.Sheets("Tabelle1"). _
Range("n3:n10002").Value
End If
ActiveWorkbook.Close
'TN-Liste erstellen
Workbooks.Add
Anzahl = ActiveWorkbook.Sheets.Count
For i = 1 To Anzahl
Sheets("Tabelle" & i).Select
Select Case i
Case Is > 1
Sheets("Tabelle" & i).Select
ActiveWindow.SelectedSheets.Delete
End Select
Next i
'Daten übertragen von Generator zu TN-Liste
ActiveWorkbook.Sheets("Tabelle1").Range("1:1").Value = ThisWorkbook.Sheets("Format TN").Range(" _
1:1").Value
ActiveWorkbook.Sheets("Tabelle1").Range("a2:a10001").Value = ThisWorkbook.Sheets("Generator"). _
Range("a1:a10000").Value
ActiveWorkbook.Sheets("Tabelle1").Range("b2:b10001").Value = ThisWorkbook.Sheets("Generator"). _
Range("b1:b10000").Value
ActiveWorkbook.Sheets("Tabelle1").Range("c2:c10001").Value = ThisWorkbook.Sheets("Generator"). _
Range("u1:u10000").Value
ActiveWorkbook.Sheets("Tabelle1").Range("d2:d10001").Value = ThisWorkbook.Sheets("Generator"). _
Range("t1:t10000").Value
ActiveWorkbook.Sheets("Tabelle1").Range("e2:e10001").Value = ThisWorkbook.Sheets("Generator"). _
Range("d1:d10000").Value
ActiveWorkbook.Sheets("Tabelle1").Range("f2:f10001").Value = ThisWorkbook.Sheets("Generator"). _
Range("f1:f10000").Value
ActiveWorkbook.Sheets("Tabelle1").Range("g2:g10001").Value = ThisWorkbook.Sheets("Generator"). _
Range("g1:g10000").Value
ActiveWorkbook.Sheets("Tabelle1").Range("h2:h10001").Value = ThisWorkbook.Sheets("Generator"). _
Range("h1:h10000").Value
ActiveWorkbook.Sheets("Tabelle1").Range("j2:j10001").Value = ThisWorkbook.Sheets("Generator"). _
Range("j1:j10000").Value
ActiveWorkbook.Sheets("Tabelle1").Range("k2:k10001").Value = ThisWorkbook.Sheets("Generator"). _
Range("k1:k10000").Value
ActiveWorkbook.Sheets("Tabelle1").Range("l2:l10001").Value = ThisWorkbook.Sheets("Generator"). _
Range("l1:l10000").Value
ActiveWorkbook.Sheets("Tabelle1").Range("m2:m10001").Value = ThisWorkbook.Sheets("Generator"). _
Range("m1:m10000").Value
ActiveWorkbook.Sheets("Tabelle1").Range("n2:n10001").Value = ThisWorkbook.Sheets("Generator"). _
Range("n1:n10000").Value
ActiveWorkbook.Sheets("Tabelle1").Range("o2:o10001").Value = ThisWorkbook.Sheets("Generator"). _
Range("o1:o10000").Value
ActiveWorkbook.Sheets("Tabelle1").Range("p2:p10001").Value = ThisWorkbook.Sheets("Generator"). _
Range("p1:p10000").Value
ActiveWorkbook.Sheets("Tabelle1").Range("q2:q10001").Value = ThisWorkbook.Sheets("Generator"). _
Range("q1:q10000").Value
ActiveWorkbook.Sheets("Tabelle1").Range("r2:r10001").Value = ThisWorkbook.Sheets("Generator"). _
Range("s1:s10000").Value
ActiveWorkbook.Sheets("Tabelle1").Range("s2:s10001").Value = "Bewerber/ MA/ TN ALLGEMEIN; _
Teilnehmer HH Modell 2008"
ActiveWorkbook.Sheets("Tabelle1").Range("u2:u10001").Value = ThisWorkbook.Sheets("Generator"). _
Range("w1:w10000").Value
'TN-Liste formatieren und speichern
ActiveWorkbook.Sheets("Tabelle1").Cells.EntireColumn.AutoFit
ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "/" & Format(Date, "YYYY/MM/DD") & " _
_Listengenerator - TN.xls", FileFormat _
:=xlNormal, Password:="", WriteResPassword:="", ReadOnlyRecommended:= _
False, CreateBackup:=False
ActiveWorkbook.Close
'Unternehmensliste erstellen
Workbooks.Add
Anzahl = ActiveWorkbook.Sheets.Count
For i = 1 To Anzahl
Sheets("Tabelle" & i).Select
Select Case i
Case Is > 1
Sheets("Tabelle" & i).Select
ActiveWindow.SelectedSheets.Delete
End Select
Next i
'Daten vom Generator zu Unternehmensliste übertragen
ActiveWorkbook.Sheets("Tabelle1").Range("1:1").Value = ThisWorkbook.Sheets("Format Unt").Range(" _
1:1").Value
ThisWorkbook.Sheets("Format Unt").Range("c2:c10001").Copy
ActiveWorkbook.Sheets("Tabelle1").Range("c2:c10001").PasteSpecial Paste:=xlFormats, Operation:= _
xlNone, SkipBlanks:=False, Transpose:=False
Set wksT = ActiveWorkbook.Sheets("Tabelle1")
lngT = 1
With ThisWorkbook.Sheets("Generator")
Do While .Cells(lngG + 1, 1) ""
lngG = lngG + 1
strAG = .Cells(lngG, 19)
strN = .Cells(lngG, 21)
lngT = lngT + 1
wksT.Cells(lngT, 2) = .Cells(lngG, 18).Value
wksT.Cells(lngT, 3) = strAG
wksT.Cells(lngT, 8) = "Unternehmen HH Modell 2008; Unternehmen ALLGEMEIN"
wksT.Cells(lngT, 10) = .Cells(lngG, 23).Value
Do While strAG = .Cells(lngG + 1, 19) And .Cells(lngG + 1, 1) ""
lngG = lngG + 1
strN = strN & "; " & .Cells(lngG, 21)
Loop
wksT.Cells(lngT, 1) = strN
Loop
End With
'Unternehmensliste formatieren und speichern
ActiveWorkbook.Sheets("Tabelle1").Cells.EntireColumn.AutoFit
With ActiveWorkbook.Sheets("Tabelle1")
.Range("a2:j10001").Sort Key1:=.Range("C2"), Order1:=xlAscending, Key2:=.Range("B2"), Order2:= _
_
xlAscending, Header:=xlNo, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
End With
ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "/" & Format(Date, "YYYY/MM/DD") & " _
_Listengenerator - Untern.xls", FileFormat _
:=xlNormal, Password:="", WriteResPassword:="", ReadOnlyRecommended:= _
False, CreateBackup:=False
ActiveWorkbook.Close
'Endmeldung
MsgBox "Die beiden neuen Datein wurden erzeugt und liegen nun im Ordner: " & ThisWorkbook.Path & _
"\" & vbCrLf & vbCrLf & "Diese Datei schließt sich nun von selbst!"
'Ordner anzeigen und Excel schließen
VZ = ThisWorkbook.Path
Shell "Explorer " & VZ, vbNormalFocus
Application.Quit
End Sub