Live-Forum - Die aktuellen Beiträge
Datum
Titel
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
1404to1408
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Makro nach dem ersten Durchlauf langsam

Makro nach dem ersten Durchlauf langsam
23.01.2015 15:16:59
Bobi
Hi,
ich habe mit Hilfe von einigen Bekannten, die sich besser als mich mit VBA auskennen, ein Makro erstellt, dass einzelne Laschen aus einer "Master-Datei" als separate Excel-Dateien mit einem vorgegebenen Namen und in einem vorgegbem Pfad abspeichert.
Anbei findet Ihr den Code. Das Makro funktioniert. Dauert allerdings beim ersten Durchlauf etwa 2-3 Sek. bis zum Abspeichern der Datei und ab dem 2. Durchlauf etwa 25-30 Sek. Da ich dieses Makro mehrmals am Tag ausführen muss, kostet mich dies einiges an Zeit und ich wäre euch extremst dankbar, falls ihr paar Tipps für mich hättet!!
Gruß,
Bobi
Option Explicit
Private Sub CB_Exit_Click()
Unload Me
End Sub
Sub GetMoreSpeed(Optional ByVal modus As Boolean = True)
Static intcalculation As Integer
If modus = True Then intcalculation = Application.Calculation
With Application
.ScreenUpdating = Not modus
.EnableEvents = Not modus
.Calculation = IIf(modus, xlManual, intcalculation)
End With
End Sub
Private Sub CB_Save_Click()
Dim Name As String
GetMoreSpeed True
If CboBx_Knd = "" Then MsgBox "Sie müssen schon einen Kunden auswählen!": Exit Sub
ThisWorkbook.Windows(1).SelectedSheets.Copy
ActiveSheet.UsedRange.Value = ActiveSheet.UsedRange.Value
With Me.CboBx_Knd
Name = Application.GetSaveAsFilename(CStr(.List(.ListIndex, 3) & .List(.ListIndex, 2) &  _
Format(Now, .List(.ListIndex, 1))), "Microsoft Excel-Arbeitsmappe (*.xlsx), *xlsx", , "Datei speichern unter...")
If Name  "" Then _
ActiveWorkbook.SaveAs Filename:=Name, FileFormat:=xlOpenXMLWorkbook, Password:="",  _
WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False
End With
ActiveWorkbook.Close
MsgBox "Gespeichert unter """ & Name & """"
Unload Me
GetMoreSpeed False
End Sub

Private Sub CboBx_Knd_Change()
End Sub

Private Sub Label1_Click()
End Sub
Private Sub UserForm_Initialize()
Dim KndArr() As Variant
Dim KndRng As Range
GetMoreSpeed True
Set KndRng = ThisWorkbook.Worksheets("Kundenverzeichnis").Cells(1, 1).CurrentRegion.Offset( _
1)
Set KndRng = KndRng.Resize(KndRng.Rows.Count - 1, KndRng.Columns.Count)
KndArr = KndRng
Sortieren2 KndArr, Array(1)
CboBx_Knd.List = KndArr
GetMoreSpeed False
End Sub

' Code Bobi 2012
Public Sub Sortieren2(vntArray() As Variant, vntSortArray As Variant)
Dim intIndex As Integer
Dim lngIndex1 As Long, lngIndex2 As Long, lngRowsArray() As Long
Dim lngRowsCount As Long, lngRangeCount As Long
Dim vntTemp As Variant
ReDim lngRowsArray(0 To 1, 0 To UBound(vntArray) * 2)
GetMoreSpeed True
'Array für den 1. Sortierlauf
lngRowsArray(0, 0) = LBound(vntArray)
lngRowsArray(0, 1) = UBound(vntArray)
lngRowsCount = 1
For intIndex = LBound(vntSortArray) To UBound(vntSortArray)
'Wenn eine Spalte angegeben
If vntSortArray(intIndex)  0 Then
lngRangeCount = -1
'Schleife zum sortieren der einzelnen Bereiche
For lngIndex1 = 0 To lngRowsCount Step 2
'Sortieren des Bereichs, wenn Zeilenzahl größer 1
If lngRowsArray(0, lngIndex1)  lngRowsArray(0, lngIndex1 + 1) Then
Call prcQuickSort(CLng(lngRowsArray(0, lngIndex1)), _
CLng(lngRowsArray(0, lngIndex1 + 1)), CInt(Abs(vntSortArray(intIndex))), _
_
CBool(vntSortArray(intIndex) > 0), vntArray())
'sortierten Bereich merken
lngRangeCount = lngRangeCount + 2
lngRowsArray(1, lngRangeCount - 1) = lngRowsArray(0, lngIndex1)
lngRowsArray(1, lngRangeCount) = lngRowsArray(0, lngIndex1 + 1)
End If
Next
lngRowsCount = -1
'Durchsuchen der soeben sortierten Spalte nach Wertewechsel
For lngIndex1 = 0 To lngRangeCount Step 2
'1. Zeile des zu sortierenden Bereichs
vntTemp = vntArray(lngRowsArray(1, lngIndex1), Abs(vntSortArray(intIndex)))
lngRowsCount = lngRowsCount + 1
lngRowsArray(0, lngRowsCount) = lngRowsArray(1, lngIndex1)
'Suche nach Wechsel innerhalb des Bereichs
For lngIndex2 = lngRowsArray(1, lngIndex1) To lngRowsArray(1, lngIndex1 + 1)
If vntTemp  vntArray(lngIndex2, Abs(vntSortArray(intIndex))) Then
lngRowsCount = lngRowsCount + 2
lngRowsArray(0, lngRowsCount - 1) = lngIndex2 - 1
lngRowsArray(0, lngRowsCount) = lngIndex2
vntTemp = vntArray(lngIndex2, Abs(vntSortArray(intIndex)))
End If
Next
'letzte Zeile des zu sortierenden Bereichs
lngRowsCount = lngRowsCount + 1
lngRowsArray(0, lngRowsCount) = lngRowsArray(1, lngIndex1 + 1)
Next
End If
Next
GetMoreSpeed False
End Sub

Private Sub prcQuickSort(lngLbound As Long, lngUbound As Long, _
intSortColumn As Integer, bntSortKey As Boolean, vntArray() As Variant)
Dim intIndex As Integer
Dim lngIndex1 As Long, lngIndex2 As Long
Dim vntTemp As Variant, vntBuffer As Variant
GetMoreSpeed True
lngIndex1 = lngLbound
lngIndex2 = lngUbound
vntBuffer = vntArray((lngLbound + lngUbound) \ 2, intSortColumn)
Do
If bntSortKey Then
Do While vntArray(lngIndex1, intSortColumn)  vntBuffer
lngIndex1 = lngIndex1 + 1
Loop
Do While vntBuffer > vntArray(lngIndex2, intSortColumn)
lngIndex2 = lngIndex2 - 1
Loop
End If
If lngIndex1  _
vntArray(lngIndex2, intSortColumn) Then
For intIndex = LBound(vntArray, 2) To UBound(vntArray, 2)
vntTemp = vntArray(lngIndex1, intIndex)
vntArray(lngIndex1, intIndex) = _
vntArray(lngIndex2, intIndex)
vntArray(lngIndex2, intIndex) = vntTemp
Next
End If
lngIndex1 = lngIndex1 + 1
lngIndex2 = lngIndex2 - 1
ElseIf lngIndex1 = lngIndex2 Then
lngIndex1 = lngIndex1 + 1
lngIndex2 = lngIndex2 - 1
End If
Loop Until lngIndex1 > lngIndex2
If lngLbound 

10
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
kannst du eine Testdatei hochladen? oT.
24.01.2015 07:21:35
Tino

AW: kannst du eine Testdatei hochladen? oT.
24.01.2015 08:08:50
Luschi
Hallo Bobi,
Zähle mal durch, wie oft in Deinem geposteten Vba-Code die Prozedur 'GetMoreSpeed' aufgerufen wird.
Ursache dürfte sein, daß in der Prozedur 'prcQuickSort' am Schluß!!! die Geschwindigkeitsbremsen ausgeschaltet werden. D.h.: alles was in der darüberliegende Prozedur 'Sortieren2' weiterläuft, arbeitet mit angezogener Handbremse.
Erst der Wiedereinstieg in 'prcQuickSort' sorgt für ein erneutes Ausschalten der Langsamkeit. Aber das nützt ja nichts, da ja am Schluß die Excel-Trödelei wieder freien Lauf hat.
Gruß von Luschi
aus klein-Paris
PS: ich teste das gerade mal ein einer Adreßtabelle mit 500 Datensätzen, komme aber zu dem Ergebnis, das nichts sortiert wird.
Frage: Welchen Sinn hat Array(1) bei folgendem Aufruf: Sortieren2 KndArr, Array(1) ?
Ist es dieSpaltennr., der der sortiert werden soll?!?

Anzeige
AW: @Luschi, alter Beitrag
24.01.2015 10:40:15
Luschi
Hallo Tino,
bin z.Z. leider viel unterwegs und mein neuer Arbeitgeber denkt, er kann mich melken wie eine bunte Kuh.
Aber ich versuche in der jetzt kommenden Woche das Angebot zu vollenden.
schöne Grüße aus dem Salzburger Land
Luschi
aus klein-Paris

AW: @Luschi, alter Beitrag
24.01.2015 10:46:08
Tino
Hallo,
wäre super!
Selbst habe ich es nicht hinbekommen.
Gruß Tino

Anzeige
AW: kannst du eine Testdatei hochladen? oT.
25.01.2015 18:58:45
Bobi
Hi,
ich werde morgen eine Datei hochladen...müsste vorher alle Kundendaten unkenntlich machen.
Vielen dank vorab!

AW: Makro nach dem ersten Durchlauf langsam
27.01.2015 16:49:53
Bobi
und noch eine kurze Erklärung:
In Lasche "Ordereingabe" wird der Iput eingegeben, anschließend durch eine Mischung aus Excel-Formeln und VBA wird dies auf die "Kunden"-Laschen verteilt. Dies ist sozusagen Teil 1 und läuft problemlos durch (ist auch sehr einfach aufgebaut)
Ziel von Teil 2 ist, dass man die einzelnen "Kunden"-Laschen als separate Excel-Dateien unter vorgegebenem Namen im vorgegebenem Pfad abspeichern kann.
Also man geht in eine von den Laschen rein, drückt auf speichern, bestätigt, dass man für einen Kunden abspeichern will und sucht sich aus für welchen Kunden dies der Fall ist. Das ist eigentlich alles. :)
Der Teil mit dem "sortieren" ist nicht von mir und ich bin selber etwas ratlos, was der Zweck sein sollte. :)
Für weitere Fragen stehe ich gerne zur Verfügung! Besten Dank vorab!
Gruß,
Bobi

Anzeige
AW: Makro nach dem ersten Durchlauf langsam
27.01.2015 17:21:57
Tino
Hallo,
habe jetzt mehrmals gespeichert wie beschrieben,
kann nicht feststellen das es langsamer wird!
Gruß Tino

AW: Makro nach dem ersten Durchlauf langsam
27.01.2015 17:35:07
Bobi
Danke, Tino!
Dann liegt es wohl an unserem System hiet im Büro. Auffällig ist nur, dass ich beim ersten Durchlauf etwa 3-4 Sek brauche bis die Datei gespeichert wird und ab dem 2. Durchlauf zwischen 25 und 30 Sek. Es ist nicht der Fall, dass das Abspeichern, dann mit jedem weiteren Durchlauf länger dauert, aber die 30 Sek. pro Durchlauf kosten mich über den gesamten Tag einiges an Zeit :(
Falls euch jedoch was auffällt, dass verbessert werden kann, wird mich sehr freuen!
Anzeige

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige