Code nachgereicht - vorsicht! länglich
06.05.2002 15:52:17
Maria
___________________________________________________________
Sub Sort_by_Division()'****************************************************************
' Laeuft noch nicht so wie's soll. Ressourcen-Probs...
'****************************************************************
Dim objDiviFind As Object
Dim rngDiviAdr As Range
Dim strDiviAdr As String
Dim intDiviCol As Integer
Dim colValues As New Collection
Dim i As Integer, j As Integer
Dim Swap1, Swap2, Item
Dim strTemplate As String
Dim strStratPath As String
Dim dtoNothing As DataObject
Set dtoNothing = New DataObject
'determine the correct path
strStratPath = accessdirectory("Root") + accessdirectory("General_Sheets")
MsgBox strStratPath
'richtige Excel-Datei aktivieren
Windows("source_bearbeitet_" + Format(Date, "yymmdd") + ".xls").Activate
'Achtung! Muss schon geoeffnet sein, ist es aber eigentlich.
'richtiges Worksheet aktivieren
Sheets("Report").Select
'zuerst die Sicherheitsabfrage, wo das Gewuenschte ist
'starting point
Rows("1:1").Select
Rows("1:1").Select
Range("A1").Activate
Set objDiviFind = ActiveSheet.Rows(1).Find(What:="Reporting Division", After:=ActiveCell, LookIn:=xlValues, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False)
objDiviFind.Select
strDiviAdr = objDiviFind.Address
intDiviCol = objDiviFind.Column
'Sorting
Selection.Sort Key1:=Range(strDiviAdr), Order1:=xlAscending, Header:=xlYes, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
' The next statement ignores the error caused
' by attempting to add a duplicate key to the collection.
' The duplicate is not added - which is just what we want!
On Error Resume Next
Cells(strDiviAdr).Select
For Each Cell In Range(Selection, Selection.End(xlDown))
colValues.Add Cell.Value, CStr(Cell.Value)
' Note: the 2nd argument (key) for the Add method must be a string
Next Cell
' Resume normal error handling
On Error GoTo 0
' Sort the collection (optional)
For i = 1 To colValues.Count - 1
For j = i + 1 To colValues.Count
If colValues(i) > colValues(j) Then
Swap1 = colValues(i)
Swap2 = colValues(j)
colValues.Add Swap1, before:=j
colValues.Add Swap2, before:=i
colValues.Remove i + 1
colValues.Remove j + 1
End If
Next j
Next i
For i = 1 To colValues.Count
If colValues.Item(i) <> "Reporting Division" Then
MsgBox colValues.Item(i)
'Filter by item
'Filter
ActiveSheet.UsedRange.AutoFilter
ActiveSheet.UsedRange.AutoFilter field:=intDiviCol, Criteria1:=colValues.Item(i)
'********************************
MsgBox colValues.Item(i) & " wurde gefiltert"
'********************************
'Disable undo for saving ressources
CanUndo = False
'select all
Cells.Select
Application.Wait Now + TimeSerial(0, 1, 0)
'Copy
Application.CutCopyMode = False
Selection.SpecialCells(xlVisible).Copy
'********************************
MsgBox colValues.Item(i) & " wurde kopiert."
'********************************
'create temporary sheet
'templates with names other than their respective entrance
Select Case colValues.Item(i)
Case "ICT"
strTemplate = "Intercity_trains"
Case "APM"
strTemplate = "TTS"
Case "LRT"
strTemplate = "TTS"
Case "ATS"
strTemplate = "TTS"
Case "INB"
strTemplate = "IN+"
Case "INC"
strTemplate = "IN+"
Case Else
strTemplate = colValues.Item(i)
End Select
On Error Resume Next
Windows("source_bearbeitet_" + Format(Date, "yymmdd") + ".xls").Activate
Worksheets("tmp_" & strTemplate).Select
If Err.Number <> 0 Then
Worksheets.Add
ActiveSheet.Name = "tmp_" & strTemplate
End If
On Error GoTo 0
'********************************
MsgBox colValues.Item(i) & " - temporäres Sheet wurde erstellt."
'********************************
'Pause
Application.Wait Now + TimeSerial(0, 2, 0)
'frueher hier zurueck zum normalen Errorhandling,
'testweise nach unten
'Prepare Paste
Sheets("tmp_" & strTemplate).Activate
ActiveSheet.Range("A1").Select
'Pause
Application.Wait Now + TimeSerial(0, 2, 0)
'Paste
Sheets("tmp_" & strTemplate).Paste
Application.CutCopyMode = False
'********************************
MsgBox colValues.Item(i) & " wurde pastiert."
'********************************
'Back to normal error handling
On Error GoTo 0
Application.DisplayAlerts = True
'Defilter
Windows("source_bearbeitet_" + Format(Date, "yymmdd") + ".xls").Activate
Sheets("Report").Activate
ActiveSheet.ShowAllData
Selection.AutoFilter
Application.Wait Now + TimeSerial(0, 2, 0)
End If
Next i
MsgBox "Fertig!!!!!!!"
End Sub
_____________________________________________________
Sobald ich BTW zwischendrin versucht habe, die Speichernutzung auszugeben, hat er meinen Zähler wieder vergessen...
So, ich hoffe das hilft Euch beim Helfen...