Excel entfernt Sortierung
13.08.2013 10:38:56
Max
Ich arbeite noch immer an meinem Tool für die Liquiditätsplanung und bin fast fertig.
Gestern habe ich das Marko noch um einen Teil ergänzt, bei dem 2 Spalten auf der Hilfstabelle Alphabetisch sortiert werden. Das Marko läuft auch komplett ohne Fehler durch. Der Fehler kommt erst zu tragen, wenn ich die Mappe schließe und erneut öffne. Dann erhalte ich folgende Fehlermeldung:
"Von Excel wurde unlesbarer Inhalt in 'Liquiditätsplanung.xlsm' gefunden. Möchten Sie den Inhalt dieser Arbeitsmappe wiederherstellen? (Ja/Nein)"
Wenn ich mit Ja bestätige kommt ein 2. Feld in dem steht: "Entfernte Datensätze: Sortierung von /xl/Worksheets/sheet6.xml-Part". Das Sheet 6 ist meine "Hilfstabelle". Die Meldung als solche stört nicht groß weiter, da die Sortierung tatsächlich noch so ist, wie beim schließen der Mappe. Allerdings muss ich beim Speichern immer wieder den richtigen Ordner manuell suchen und dann die Datei überschreiben.
Und ich hätte da noch eine 2. kleine Frage:
Warum muss ich 2x Application.ScreenUpdating = False schreiben um das Monitorflackern endgültig los zu werden, obwohl ich ja extra noch auf ein "Ladebildschirm" springe?
Da ich noch ein VBA Rookie bin, poste ich hier mal meinen gesamten Code.
Hoffe Ihr könnt mir helfen.
Private Sub xCopy3()
Application.ScreenUpdating = False
Application.Cursor = xlWait
Application.Calculation = xlCalculationManual
Worksheets("Ladebildschirm").Visible = True
Worksheets("Ladebildschirm").Activate
'Import
Worksheets("Debitoren OP-Liste").Cells.Clear
Worksheets("Kreditoren Fälligkeitsübersicht").Cells.Clear
Dim QWB As Workbook, QWB2 As Workbook, ZWB As Workbook
Workbooks.Open "G:\Liquidität\Excel Export Debitoren OP-Liste (aus Anzeige).xlsx"
Workbooks.Open "G:\Liquidität\Excel Export Kreditoren Faelligkeitsuebersicht (aus Anzeige).xlsx" _
_
Set QWB = Workbooks("Excel Export Debitoren OP-Liste (aus Anzeige).xlsx")
Set QWB2 = Workbooks("Excel Export Kreditoren Faelligkeitsuebersicht (aus Anzeige).xlsx")
Set ZWB = ThisWorkbook
Dim QWS As Worksheet, QWS2 As Worksheet, ZWS As Worksheet, ZWS2 As Worksheet
Set QWS = QWB.Worksheets("Debitoren OP-Liste")
Set ZWS = ZWB.Worksheets("Debitoren OP-Liste")
Set QWS2 = QWB2.Worksheets("Kreditoren Fälligkeitsübersicht")
Set ZWS2 = ZWB.Worksheets("Kreditoren Fälligkeitsübersicht")
QWS.Cells.Copy ZWS.Cells(1, 1)
QWS2.Cells.Copy ZWS2.Cells(1, 1)
Workbooks("Excel Export Debitoren OP-Liste (aus Anzeige).xlsx").Close
Workbooks("Excel Export Kreditoren Faelligkeitsuebersicht (aus Anzeige).xlsx").Close
'Kurs ausschneiden
Dim i As Long
For i = 2 To 1000
If Worksheets("Debitoren Op-Liste").Cells(i, "Q").Value = "Kurs:" Then
Worksheets("Debitoren Op-Liste").Cells(i, "Q").Cut Destination:=Worksheets("Debitoren Op- _
Liste").Cells(i, "T")
Worksheets("Debitoren Op-Liste").Cells(i, "O").Clear
End If
Next i
'Nullen_löschen
Dim e As Long
For e = 2 To 1000
If Worksheets("Debitoren Op-Liste").Cells(e, "O").Value = 0 Then
Worksheets("Debitoren Op-Liste").Cells(e, "O").Clear
End If
Next e
'einblenden alles
Worksheets("Liquiditätsplanung").Rows("41:139").EntireRow.Hidden = False
'OPs kopieren
Dim r As Long, n As Long
n = 19
Worksheets("Hilfstabelle").Range("L:L").Clear
For r = 2 To 1000
If Worksheets("Debitoren OP-Liste").Cells(r, "O").Value 0 Then
n = n + 1
Worksheets("Debitoren OP-Liste").Cells(r, "O").Copy Destination:=Worksheets("Hilfstabelle"). _
_
Cells(n, "L")
End If
Next r
'Datum umwandeln
Worksheets("Debitoren OP-Liste").Columns("Q:Q").TextToColumns DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
:=Array(1, 4), TrailingMinusNumbers:=True
Calculate
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
'Matrix für Umbuchungen
Dim m, a, b As Long
Worksheets("Hilfstabelle").Range("V:Z").Clear
a = 19
b = 19
For m = 20 To 219
If Worksheets("Hilfstabelle").Cells(m, "K").Value "" Then
a = a + 1
Worksheets("Hilfstabelle").Cells(m, "K").Copy
Worksheets("Hilfstabelle").Cells(a, "W").PasteSpecial xlValues
End If
If Worksheets("Hilfstabelle").Cells(m, "L").Value "" Then
Worksheets("Hilfstabelle").Cells(m, "L").Copy
Worksheets("Hilfstabelle").Cells(a, "X").PasteSpecial xlValues
End If
Next m
'Matrix sortieren
Worksheets("Hilfstabelle").Sort.SortFields.Add Key:=Range( _
"W20"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortNormal
With Worksheets("Hilfstabelle").Sort
.SetRange Range("W20:X219")
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
'Kunden 1x
For m = 20 To 219
If Worksheets("Hilfstabelle").Cells(m, "W").Value "" Then
b = b + 1
If Worksheets("Hilfstabelle").Cells(m - 1, "W").Value = Worksheets("Hilfstabelle").Cells(m, _
_
"W").Value Then
Worksheets("Hilfstabelle").Cells(m, "V").Value = ""
Else: Worksheets("Hilfstabelle").Cells(m, "W").Copy
Worksheets("Hilfstabelle").Cells(b, "V").PasteSpecial xlValues
End If
End If
Next m
'ausblenden_Kleinbeträge
Dim z As Long
For z = 41 To 139
If Worksheets("Liquiditätsplanung").Cells(z, "B").Value