PDA

Vollständige Version anzeigen : Makro braucht unterschiedlich lange Zeit


Saerdna61
18.08.2017, 20:43
Hallo in die Expertenrunde :)

Stehe mal wieder vor einem kleinen Problem oder zumindest finde ich keine Erklärung dafür.

Wenn ich den nachfolgenden Code aus dem VBA Fenster (Entwicklerumgebung) aufrufe, benötigt er genau 0,36 Sekunden. Das ist in Ordnung. :D
Rufe ich den Code mit Call aus der Arbeitsmappe heraus auf, benötigt "er" 16,53 mal so lange, ziemlich genau 5,95 Sekunden und der Mauszeiger flackert.
Weder in dem Sheet, aus dem ich die Daten abrufe, noch in dem Sheet in das ich die Daten schreibe, ist VBA Code hinterlegt. Einzig im abrufenden Sheet sind viele Sverweise und Verknüpfungen zu anderen Sheets in der gleichen Arbeitsmappe. Aber aus dem Sheet lese ich ja nur....

Application.ScreenUpdating = False
und
Application.Calculation = xlCalculationManual

sind selbstverständlich gesetzt. :)


Ach ja, Hintergrund ist, dass ich diesen Code im Workbook_BeforeClose Ereignis mit Call aufrufen möchte um sicher zu gehen, dass das Sheet "Kundenzeiten" den aktuellen (letzten) Stand hat. (Benötige ich um über eine andere Datei diese Informationen als Zusammenfassung aller Arbeitsmappen (Dateien) darstellen zu können. Deshalb sollte der Code vor dem schließen der Arbeitsmappe auch Fix durchlaufen. :cool:

Hier nun der Code, wobei ich nicht glaube, dass es an diesem Selbst liegt. Im Lokalfenster von VBA kann ich auch keine "Ungereimtheiten" finden.


Public Sub KdZeitÜbertrag() ' Übertrag aller mit Kundenzeiten belegten Zellen in ein neues Sheet

Dim Zeit As Variant
Dim TempList(369, 5) As String
Dim Zeile As Long, Zähler As Long
Dim Spalte As Integer
Dim ZeilenNr As Long
Dim SpaltenNr As Long
Dim letzteZeile As Long

Zeit = Timer

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

ZeilenNr = 1
Spalte = 1

letzteZeile = Sheets("Kundenzeiten").Cells(Rows.Count, 1).End(xlUp).Row

Sheets("Kundenzeiten").Cells.Clear

' Ersten Kundenbereich abfragen
For Zeile = 4 To 369

If Sheets("Gesamtjahr").Cells(Zeile, 3).Value <> "" Then
For SpaltenNr = 1 To 5
TempList(ZeilenNr, SpaltenNr) = Sheets("Gesamtjahr").Cells(Zeile, Spalte)
Spalte = Spalte + 1
Next SpaltenNr
Spalte = 1
ZeilenNr = ZeilenNr + 1
End If

Next Zeile

ZeilenNr = 1

For Zeile = LBound(TempList) To UBound(TempList) - 1

Sheets("Kundenzeiten").Cells(ZeilenNr, 1).Value = TempList(ZeilenNr, 1)
Sheets("Kundenzeiten").Cells(ZeilenNr, 2).Value = TempList(ZeilenNr, 2)
Sheets("Kundenzeiten").Cells(ZeilenNr, 3).Value = TempList(ZeilenNr, 3)
Sheets("Kundenzeiten").Cells(ZeilenNr, 4).Value = TempList(ZeilenNr, 4)
Sheets("Kundenzeiten").Cells(ZeilenNr, 5).Value = TempList(ZeilenNr, 5)

ZeilenNr = ZeilenNr + 1
letzteZeile = letzteZeile + 1
Next Zeile

Erase TempList

' Zweiten Kundenbereich abfragen
ZeilenNr = 1

For Zeile = 4 To 369

If Sheets("Gesamtjahr").Cells(Zeile, 6).Value <> "" Then
For SpaltenNr = 1 To 5
TempList(ZeilenNr, 1) = Sheets("Gesamtjahr").Cells(Zeile, 1)
TempList(ZeilenNr, 2) = Sheets("Gesamtjahr").Cells(Zeile, 2)

TempList(ZeilenNr, 3) = Sheets("Gesamtjahr").Cells(Zeile, 6)
TempList(ZeilenNr, 4) = Sheets("Gesamtjahr").Cells(Zeile, 7)
TempList(ZeilenNr, 5) = Sheets("Gesamtjahr").Cells(Zeile, 8)
Next SpaltenNr
ZeilenNr = ZeilenNr + 1
End If

Next Zeile

ZeilenNr = 1

letzteZeile = Sheets("Kundenzeiten").Cells(Rows.Count, 1).End(xlUp).Row + 1

For Zeile = LBound(TempList) To UBound(TempList) - 1
Sheets("Kundenzeiten").Cells(letzteZeile, 1).Value = TempList(ZeilenNr, 1)
Sheets("Kundenzeiten").Cells(letzteZeile, 2).Value = TempList(ZeilenNr, 2)
Sheets("Kundenzeiten").Cells(letzteZeile, 3).Value = TempList(ZeilenNr, 3)
Sheets("Kundenzeiten").Cells(letzteZeile, 4).Value = TempList(ZeilenNr, 4)
Sheets("Kundenzeiten").Cells(letzteZeile, 5).Value = TempList(ZeilenNr, 5)

ZeilenNr = ZeilenNr + 1
letzteZeile = letzteZeile + 1
Next Zeile

Erase TempList

' Dritten Kundenbereich abfragen
ZeilenNr = 1

For Zeile = 4 To 369

If Sheets("Gesamtjahr").Cells(Zeile, 9).Value <> "" Then
For SpaltenNr = 1 To 5
TempList(ZeilenNr, 1) = Sheets("Gesamtjahr").Cells(Zeile, 1)
TempList(ZeilenNr, 2) = Sheets("Gesamtjahr").Cells(Zeile, 2)

TempList(ZeilenNr, 3) = Sheets("Gesamtjahr").Cells(Zeile, 9)
TempList(ZeilenNr, 4) = Sheets("Gesamtjahr").Cells(Zeile, 10)
TempList(ZeilenNr, 5) = Sheets("Gesamtjahr").Cells(Zeile, 11)
Next SpaltenNr
ZeilenNr = ZeilenNr + 1
End If

Next Zeile

ZeilenNr = 1

letzteZeile = Sheets("Kundenzeiten").Cells(Rows.Count, 1).End(xlUp).Row + 1

For Zeile = LBound(TempList) To UBound(TempList) - 1
Sheets("Kundenzeiten").Cells(letzteZeile, 1).Value = TempList(ZeilenNr, 1)
Sheets("Kundenzeiten").Cells(letzteZeile, 2).Value = TempList(ZeilenNr, 2)
Sheets("Kundenzeiten").Cells(letzteZeile, 3).Value = TempList(ZeilenNr, 3)
Sheets("Kundenzeiten").Cells(letzteZeile, 4).Value = TempList(ZeilenNr, 4)
Sheets("Kundenzeiten").Cells(letzteZeile, 5).Value = TempList(ZeilenNr, 5)


ZeilenNr = ZeilenNr + 1
letzteZeile = letzteZeile + 1
Next Zeile

Erase TempList

' Vierten Kundenbereich abfragen
ZeilenNr = 1

For Zeile = 4 To 369

If Sheets("Gesamtjahr").Cells(Zeile, 12).Value <> "" Then
For SpaltenNr = 1 To 5
TempList(ZeilenNr, 1) = Sheets("Gesamtjahr").Cells(Zeile, 1)
TempList(ZeilenNr, 2) = Sheets("Gesamtjahr").Cells(Zeile, 2)

TempList(ZeilenNr, 3) = Sheets("Gesamtjahr").Cells(Zeile, 12)
TempList(ZeilenNr, 4) = Sheets("Gesamtjahr").Cells(Zeile, 13)
TempList(ZeilenNr, 5) = Sheets("Gesamtjahr").Cells(Zeile, 14)
Next SpaltenNr
ZeilenNr = ZeilenNr + 1
End If

Next Zeile

ZeilenNr = 1

letzteZeile = Sheets("Kundenzeiten").Cells(Rows.Count, 1).End(xlUp).Row + 1

For Zeile = LBound(TempList) To UBound(TempList) - 1
Sheets("Kundenzeiten").Cells(letzteZeile, 1).Value = TempList(ZeilenNr, 1)
Sheets("Kundenzeiten").Cells(letzteZeile, 2).Value = TempList(ZeilenNr, 2)
Sheets("Kundenzeiten").Cells(letzteZeile, 3).Value = TempList(ZeilenNr, 3)
Sheets("Kundenzeiten").Cells(letzteZeile, 4).Value = TempList(ZeilenNr, 4)
Sheets("Kundenzeiten").Cells(letzteZeile, 5).Value = TempList(ZeilenNr, 5)

ZeilenNr = ZeilenNr + 1
letzteZeile = letzteZeile + 1
Next Zeile

Erase TempList

Sheets("Kundenzeiten").Sort.SortFields.Clear
Sheets("Kundenzeiten").Sort.SortFields.Add Key:=Range("B1:B" & letzteZeile), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortTextAsNumbers
With Sheets("Kundenzeiten").Sort
.SetRange Range("A1:E" & letzteZeile)
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With

Application.Calculation = xlCalculationAutomatic
MsgBox "Zeitbedarf " & Round(Timer - Zeit, 2) & " Sekunden"

End Sub



Viele Grüße

Andreas

lupo1
18.08.2017, 21:09
Setze im Code Timerpunkte. Am Ende schreibst Du das Array mit den Zeiten in eine Tabelle und analysierst die einzelnen Zeitstrecken im Makro.

Saerdna61
19.08.2017, 08:46
Hallo lupo1,

habe ich soweit gemacht.

Erste Spalte VBA / Zweite Spalte Excel

0,08000 0,98000 1. Bereich
0,06000 1,52000 2. Bereich
0,06000 1,55000 3. Bereich
0,06000 1,53000 4. Bereich


Wie geschrieben, zumindest ich kann keine Unstimmigkeiten/Auffälligkeiten/Besonderheiten erkennen.
Einmal letzteZeile = Sheets("Kundenzeiten").Cells(Rows.Count, 1).End(xlUp).Row + 1 ganz am Anfang habe ich herausgenommen weil ich es für den ersten Bereich nicht benötige.
Habe jetzt auch mal zum testen sämtliche Verweise und Verknüpfungen aus dem auszulesenden Sheet entfernt, Ergebnis bleibt allerdings gleich. Daran "scheint" es nicht zu liegen.

Macht denn Excel irgendetwas im Hintergrund, was der direkte Aufruf aus VBA heraus offensichtlich nicht macht und was sich nicht abstellen lässt?

Application.ScreenUpdating = False
und
Application.Calculation = xlCalculationManual

ist ja schon enthalten. Normalerweise sollte die Applikation dadurch doch ruhig gestellt sein, oder nicht?

Beverly
19.08.2017, 09:47
Hi,

hast du mal den Code direkt ins BeforeClose-Ereignis geschrieben ohne ihn mittels Call zu starten?

<hr width="20%" align="left"><img src="http://excel-inn.de/images/grusz.gif" height=35" align="left" alt="Grußformel"><a href="http://excel-inn.de/"><img border="0" src="http://excel-inn.de/images/logo1.gif" height=35" align="middle" alt="Beverly's Excel - Inn"></a>

Luschi
19.08.2017, 09:51
Hallo Andreas,

zu den Einstellungen, die man ebenfalls für 'ne Weile Schlafen legen sollte, gehört auch:
Application.EnableEvents = False

Gruß von Luschi
aus klein-Paris

Saerdna61
19.08.2017, 10:10
Hallo Beverly,

habe ich soeben ausprobiert aber leider keine Veränderung am Ergebnis. Laufzeit knapp 6 Sekunden. Egal ob der komplette Code im BeforeClose-Ereignis steht oder ob ich "ihn" mit Call im BeforeClose-Ereignis aufrufe.

Hallo Luschi,

hatte ich ursprünglich ebenfalls eingebaut (soeben auch nochmals probiert), aber keine Veränderung an der Laufzeit und/oder am Verhalten des Mauszeigers (flackern) bei Start aus Excel heraus.

Irgendetwas scheint Excel im Hintergrund zu machen, dass zum einen die Laufzeit verlängert und zum anderen das "flackern" des Mauszeigers auslöst.

Sobald ich das Makro aus VBA heraus starte beträgt die Laufzeit rund 0,3xxx Sekunden und die Applikation ist komplett ruhig.

Saerdna61
19.08.2017, 13:46
Sodele würde der Schwabe sagen :mrcool:

Nachdem ich keine Erklärung für das o.g. Verhalten finden konnte und mir die Zeit beim schließen der Datei durch die Laufzeit des Makros zu lange gedauert hat, habe ich den Code umgeschrieben. Ich lese jetzt das Array mit "einem Schlag" in die Tabelle ein und siehe da, die Laufzeit hat sich nun sogar auf 0,12 Sekunden verkürzt. Und das wichtigste, unabhängig von wo aus ich den Code nun starte. :)

Hier noch der Code.


Public Sub KdZeitÜbertrag() ' Übertrag aller mit Kundenzeiten belegten Zellen in ein neues Sheet für die spätere Abfrage

Dim Zeit As Variant
Dim TempList(369, 5) As String
Dim Zeile As Long, Zähler As Long
Dim Spalte As Integer
Dim ZeilenNr As Long
Dim SpaltenNr As Long
Dim letzteZeile As Long

Zeit = Timer

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.DisplayAlerts = False
Application.EnableEvents = False

ZeilenNr = 0
Spalte = 1

Sheets("Kundenzeiten").Cells.Clear

' Ersten Kundenbereich abfragen

For Zeile = 4 To 369

If Sheets("Gesamtjahr").Cells(Zeile, 3).Value <> "" Then
For SpaltenNr = 1 To 5
TempList(ZeilenNr, 0) = Sheets("Gesamtjahr").Cells(Zeile, 1)
TempList(ZeilenNr, 1) = Sheets("Gesamtjahr").Cells(Zeile, 2)
TempList(ZeilenNr, 2) = Sheets("Gesamtjahr").Cells(Zeile, 3)
TempList(ZeilenNr, 3) = Sheets("Gesamtjahr").Cells(Zeile, 4)
TempList(ZeilenNr, 4) = Sheets("Gesamtjahr").Cells(Zeile, 5)
Next SpaltenNr
ZeilenNr = ZeilenNr + 1
End If
Next Zeile

Sheets("Kundenzeiten").Range(Cells(1, 1), Cells(369, 5)) = TempList

Erase TempList

' Zweiten Kundenbereich abfragen

ZeilenNr = 0

For Zeile = 4 To 369

If Sheets("Gesamtjahr").Cells(Zeile, 6).Value <> "" Then
For SpaltenNr = 1 To 5
TempList(ZeilenNr, 0) = Sheets("Gesamtjahr").Cells(Zeile, 1)
TempList(ZeilenNr, 1) = Sheets("Gesamtjahr").Cells(Zeile, 2)

TempList(ZeilenNr, 2) = Sheets("Gesamtjahr").Cells(Zeile, 6)
TempList(ZeilenNr, 3) = Sheets("Gesamtjahr").Cells(Zeile, 7)
TempList(ZeilenNr, 4) = Sheets("Gesamtjahr").Cells(Zeile, 8)
Next SpaltenNr
ZeilenNr = ZeilenNr + 1
End If

Next Zeile

letzteZeile = Sheets("Kundenzeiten").Cells(Rows.Count, 1).End(xlUp).Row + 1

Sheets("Kundenzeiten").Range(Cells(letzteZeile, 1), Cells(UBound(TempList) - 1, 5)) = TempList

Erase TempList

' Dritten Kundenbereich abfragen

ZeilenNr = 0

For Zeile = 4 To 369

If Sheets("Gesamtjahr").Cells(Zeile, 9).Value <> "" Then
For SpaltenNr = 1 To 5
TempList(ZeilenNr, 0) = Sheets("Gesamtjahr").Cells(Zeile, 1)
TempList(ZeilenNr, 1) = Sheets("Gesamtjahr").Cells(Zeile, 2)

TempList(ZeilenNr, 2) = Sheets("Gesamtjahr").Cells(Zeile, 9)
TempList(ZeilenNr, 3) = Sheets("Gesamtjahr").Cells(Zeile, 10)
TempList(ZeilenNr, 4) = Sheets("Gesamtjahr").Cells(Zeile, 11)
Next SpaltenNr
ZeilenNr = ZeilenNr + 1
End If

Next Zeile

letzteZeile = Sheets("Kundenzeiten").Cells(Rows.Count, 1).End(xlUp).Row + 1

Sheets("Kundenzeiten").Range(Cells(letzteZeile, 1), Cells(UBound(TempList) - 1, 5)) = TempList

Erase TempList

' Vierten Kundenbereich abfragen

ZeilenNr = 0

For Zeile = 4 To 369

If Sheets("Gesamtjahr").Cells(Zeile, 12).Value <> "" Then
For SpaltenNr = 1 To 5
TempList(ZeilenNr, 0) = Sheets("Gesamtjahr").Cells(Zeile, 1)
TempList(ZeilenNr, 1) = Sheets("Gesamtjahr").Cells(Zeile, 2)

TempList(ZeilenNr, 2) = Sheets("Gesamtjahr").Cells(Zeile, 12)
TempList(ZeilenNr, 3) = Sheets("Gesamtjahr").Cells(Zeile, 13)
TempList(ZeilenNr, 4) = Sheets("Gesamtjahr").Cells(Zeile, 14)
Next SpaltenNr
ZeilenNr = ZeilenNr + 1
End If

Next Zeile

letzteZeile = Sheets("Kundenzeiten").Cells(Rows.Count, 1).End(xlUp).Row + 1

Sheets("Kundenzeiten").Range(Cells(letzteZeile, 1), Cells(UBound(TempList) - 1, 5)) = TempList

Erase TempList

' Sortierung nach Datum aufsteigend

letzteZeile = Sheets("Kundenzeiten").Cells(Rows.Count, 1).End(xlUp).Row

Sheets("Kundenzeiten").Sort.SortFields.Clear
Sheets("Kundenzeiten").Sort.SortFields.Add Key:=Range("B1:B" & letzteZeile), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortTextAsNumbers
With Sheets("Kundenzeiten").Sort
.SetRange Range("A1:E" & letzteZeile)
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With

Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.EnableEvents = True

MsgBox "Zeitbedarf " & Round(Timer - Zeit, 2) & " Sekunden"

End Sub


Für das andere Verhalten finde ich aber nach wie vor keine Erklärung. :(

Wahrscheinlich hing es mit dem rausschreiben und einlesen auf Zeileneben zusammen.......

lupo1
19.08.2017, 14:14
Manchmal lernt man eine neue Technik beim Nichtlösen eines Problems ;)

Beverly
19.08.2017, 15:11
Hi Andreas,

hast du mal getestet wenn du kein Array verwendest sondern Autofilter, einfach in der entsprechenden Spalte nach "nicht leere" filterst und dann nur die sichtbaren Zellen als ganzes kopierst? Dann musst du nicht in einer Schleife über die Zeilen 4 bis 369 laufen, was ja auch Zeit kostet.

<hr width="20%" align="left"><img src="http://excel-inn.de/images/grusz.gif" height=35" align="left" alt="Grußformel"><a href="http://excel-inn.de/"><img border="0" src="http://excel-inn.de/images/logo1.gif" height=35" align="middle" alt="Beverly's Excel - Inn"></a>

Saerdna61
20.08.2017, 09:47
@lupo1

In der Tat und man(n) lernt jeden Tag etwas Neues hinzu. :)

Bin ja noch in der Übungsphase mit VBA und taste mich langsam an einen "guten" Code heran. Wobei ich feststelle, dass viele Wege zum Ziel führen, der eine schneller und der andere langsamer. :rolleyes:

@ Beverly

Habe ich mir gerade angeschaut und laut MS erst ab der Version 2013 einsetzbar. Die Datei sollte aber ab der Version 2010 lauffähig sein.
Zudem stolpere ich darüber, dass ich ja insgesamt 4 Bereiche abfragen muss:

1. Bereich von A4:E369 (In Spalte B steht das Datum und in Spalte A ein eindeutiger Bezug zu einem Mitarbeiter) "Bedingung für diese Schleife" steht in der Spalte C.
2. Bereich von A4:B369 UND F4:H360 "Bedingung" für diese Schleife steht in der Spalte F.
3. Bereich von A4:B369 UND I4:K369 "Bedingung" für diese Schleife steht in der Spalte I.
4. Bereich von A4:B369 UND L4:N369 "Bedingung" für diese Schleife steht in der Spalte L.

Die Spalten A und B benötige ich bei jedem Durchlauf da ich das Datum und die eindeutige "Kennung des Mitarbeiters benötige.
Habe Dir/Euch mal meine TEST-Datei (Ein Auszug aus der kompletten Datei ohne Verweise, Formeln und Makros) angehängt. Im Sheet "Gesamtjahr" steht die Essenz der Eingaben in dem Workbook. Im Sheet "Kundenzeiten" benötige ich im Prinzip die gleiche Information (ich weiß, ist Redundant :rolleyes: ) aus den vier Bereichen in sozusagen einem Bereich gebündelt um diese Information dann aus einer anderen Datei "einfach" auslesen zu können um damit einen Zusammenfassung zu erstellen. Aktuelle lese ich rund 20 geschlossene Excel-Dateien aus.

Hier auch nochmal der aktuelle Code für den Übertrag der Informationen.


Public Sub KdZeitÜbertrag() ' Übertrag aller mit Kundenzeiten belegten Zellen in ein neues Sheet für die spätere Abfrage

'Dim Zeit As Variant
Dim TempList(369, 5) As String
Dim Zeile As Long, Zähler As Long
Dim Spalte As Integer
Dim ZeilenNr As Long
Dim SpaltenNr As Long
Dim letzteZeile As Long

'Zeit = Timer

With Application
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
.DisplayAlerts = False
End With

ZeilenNr = 0
Spalte = 1

Sheets("Kundenzeiten").Cells.Clear

' Ersten Kundenbereich abfragen

For Zeile = 4 To 369

If Sheets("Gesamtjahr").Cells(Zeile, 3).Value <> "" Then
For SpaltenNr = 1 To 5
TempList(ZeilenNr, 0) = Sheets("Gesamtjahr").Cells(Zeile, 1)
TempList(ZeilenNr, 1) = Sheets("Gesamtjahr").Cells(Zeile, 2)
TempList(ZeilenNr, 2) = Sheets("Gesamtjahr").Cells(Zeile, 3)
TempList(ZeilenNr, 3) = Sheets("Gesamtjahr").Cells(Zeile, 4)
TempList(ZeilenNr, 4) = Sheets("Gesamtjahr").Cells(Zeile, 5)
Next SpaltenNr
ZeilenNr = ZeilenNr + 1
End If
Next Zeile

Sheets("Kundenzeiten").Range("A1:E369") = TempList

Erase TempList

' Zweiten Kundenbereich abfragen

ZeilenNr = 0

For Zeile = 4 To 369

If Sheets("Gesamtjahr").Cells(Zeile, 6).Value <> "" Then
For SpaltenNr = 1 To 5
TempList(ZeilenNr, 0) = Sheets("Gesamtjahr").Cells(Zeile, 1)
TempList(ZeilenNr, 1) = Sheets("Gesamtjahr").Cells(Zeile, 2)

TempList(ZeilenNr, 2) = Sheets("Gesamtjahr").Cells(Zeile, 6)
TempList(ZeilenNr, 3) = Sheets("Gesamtjahr").Cells(Zeile, 7)
TempList(ZeilenNr, 4) = Sheets("Gesamtjahr").Cells(Zeile, 8)
Next SpaltenNr
ZeilenNr = ZeilenNr + 1
End If

Next Zeile

letzteZeile = Sheets("Kundenzeiten").Cells(Rows.Count, 1).End(xlUp).Row + 1

Sheets("Kundenzeiten").Range("A" & letzteZeile & ":E" & UBound(TempList) - 1) = TempList

Erase TempList

' Dritten Kundenbereich abfragen

ZeilenNr = 0

For Zeile = 4 To 369

If Sheets("Gesamtjahr").Cells(Zeile, 9).Value <> "" Then
For SpaltenNr = 1 To 5
TempList(ZeilenNr, 0) = Sheets("Gesamtjahr").Cells(Zeile, 1)
TempList(ZeilenNr, 1) = Sheets("Gesamtjahr").Cells(Zeile, 2)

TempList(ZeilenNr, 2) = Sheets("Gesamtjahr").Cells(Zeile, 9)
TempList(ZeilenNr, 3) = Sheets("Gesamtjahr").Cells(Zeile, 10)
TempList(ZeilenNr, 4) = Sheets("Gesamtjahr").Cells(Zeile, 11)
Next SpaltenNr
ZeilenNr = ZeilenNr + 1
End If

Next Zeile

letzteZeile = Sheets("Kundenzeiten").Cells(Rows.Count, 1).End(xlUp).Row + 1

Sheets("Kundenzeiten").Range("A" & letzteZeile & ":E" & UBound(TempList) - 1) = TempList

Erase TempList

' Vierten Kundenbereich abfragen

ZeilenNr = 0

For Zeile = 4 To 369

If Sheets("Gesamtjahr").Cells(Zeile, 12).Value <> "" Then
For SpaltenNr = 1 To 5
TempList(ZeilenNr, 0) = Sheets("Gesamtjahr").Cells(Zeile, 1)
TempList(ZeilenNr, 1) = Sheets("Gesamtjahr").Cells(Zeile, 2)

TempList(ZeilenNr, 2) = Sheets("Gesamtjahr").Cells(Zeile, 12)
TempList(ZeilenNr, 3) = Sheets("Gesamtjahr").Cells(Zeile, 13)
TempList(ZeilenNr, 4) = Sheets("Gesamtjahr").Cells(Zeile, 14)
Next SpaltenNr
ZeilenNr = ZeilenNr + 1
End If

Next Zeile

letzteZeile = Sheets("Kundenzeiten").Cells(Rows.Count, 1).End(xlUp).Row + 1

Sheets("Kundenzeiten").Range("A" & letzteZeile & ":E" & UBound(TempList) - 1) = TempList

Erase TempList

' Sortierung nach Datum aufsteigend

letzteZeile = Sheets("Kundenzeiten").Cells(Rows.Count, 1).End(xlUp).Row

Sheets("Kundenzeiten").Sort.SortFields.Clear
Sheets("Kundenzeiten").Sort.SortFields.Add Key:=Range("B1:B" & letzteZeile), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortTextAsNumbers
With Sheets("Kundenzeiten").Sort
.SetRange Range("A1:E" & letzteZeile)
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With

With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlAutomatic
.DisplayAlerts = True
End With

'MsgBox "Zeitbedarf " & Round(Timer - Zeit, 2) & " Sekunden"

End Sub


Wenn es eine Idee gibt diesen Code noch "kompakter" zu gestalten, bin ich natürlich für jede Hilfe dankbar. :)

klin89
20.08.2017, 13:19
Hallo alle miteinander, :)

Option Explicit
Sub transpose()
Dim a, b(), i As Long, j As Long, n As Long
With Sheets("Gesamtjahr").Range("a2").CurrentRegion
a = .Value
ReDim b(1 To (UBound(a, 1) * (UBound(a, 2) - 3) / 3), 1 To 5)
End With
n = 1: b(1, 1) = "---": b(1, 2) = "Datum"
b(1, 3) = "Auftrags-Nr.": b(1, 4) = "Kunde": b(1, 5) = "Zeit"
For i = 3 To UBound(a, 1)
For j = 3 To UBound(a, 2) - 1 Step 3
If Not IsEmpty(a(i, j)) Then
n = n + 1
b(n, 1) = a(i, 1)
b(n, 2) = a(i, 2)
b(n, 3) = a(i, j)
b(n, 4) = a(i, j + 1)
b(n, 5) = a(i, j + 2)
End If
Next
Next
Application.ScreenUpdating = True
With Sheets("Kundenzeiten").Range("a1")
.CurrentRegion.Clear
With .Resize(n, UBound(b, 2))
.Value = b
.Font.Name = "calibri"
.Font.Size = 10
'.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.Borders(xlInsideVertical).Weight = xlThin
.BorderAround Weight:=xlThin
With .Rows(1)
.Font.Size = 11
.Interior.ColorIndex = 43
.HorizontalAlignment = xlCenter
.BorderAround Weight:=xlThin
End With
.Columns.AutoFit
End With
End With
Application.ScreenUpdating = True
End Sub
klin89

Saerdna61
20.08.2017, 14:45
Hallo klin89,

vielen Dank für Deine Arbeit. :)

Auf den ersten Blick seeeehr kompakt.

Allerdings ist das Ergebnis nicht das was ich benötige. ;)

Wenn Du die von mir angehängte Datei aus dem letzten Post von mir anschaust, steht in dem Tab-Reiter "Kundenzeiten" das Ergebnis meines Codes. Genauso benötige ich die Info um aus einer anderen Datei die Informationen abrufen zu können.
Bei Deinem Code lese ich in Summe 537 Zeilen aus, bei "meinem richtigen" Ergebnis sind es allerdings nur 165 Zeilen.

Bei Deinem Code stimmt irgendwie die Zuordnung nicht (liest auch Zeilen ohne die Bedingung zu erfüllen in das Array) und wenn ich dies richtig sehe, liest "er" auch die letzte Spalte aus dem Gesamtjahr aus, welche ich aber nicht benötige. ;) Siehe dazu auch den Anhang mit dem Ergebnis "Deines" Codes.

Aber Du hast ein paar gute Umsetzungsideen in Deinem Code.

Wenn Du Lust kannst Du dich ja nochmals versuchen, würde mich freuen. :)

Ach ja. beide Sheets sind für den User nicht sichtbar (besteht somit auch kein direkter Zugriff darauf). Einzig das Sheet Gesamtjahr stelle ich im Menü der UF als Ausdruck zu Verfügung, deshalb hier auch die Formatierung. Im Sheet Kundenzeiten ist keine Formatierung notwendig.

Beverly
20.08.2017, 18:01
@ Beverly

Habe ich mir gerade angeschaut und laut MS erst ab der Version 2013 einsetzbar. Die Datei sollte aber ab der Version 2010 lauffähig sein.




WAS soll erst ab Version 2013 einsetzbar sein? Nach "nicht leeren filtern" kann man auch in Excel 2010 (siehe rot markierter Teil):

Sub Kopieren()
Dim lngErste As Long
Dim lngLetzte As Long
Dim intSpalte As Integer
lngErste = 1
Worksheets("Kundenzeiten").Cells.Clear
With Worksheets("Gesamtjahr")
lngLetzte = .Cells.Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
If .AutoFilter Is Nothing Then .Range(.Cells(3, 2), .Cells(lngLetzte, 15)).AutoFilter
For intSpalte = 3 To 12 Step 3
.AutoFilter.Range.AutoFilter Field:=intSpalte, Criteria1:="<>"
.Range(.Cells(4, 1), .Cells(lngLetzte, 1)).Cells.SpecialCells(xlCellTypeVisible).Copy
Worksheets("Kundenzeiten").Cells(lngErste, 1).PasteSpecial Paste:=xlValues
.Range(.Cells(4, 2), .Cells(lngLetzte, 2)).Cells.SpecialCells(xlCellTypeVisible).Copy _
Worksheets("Kundenzeiten").Cells(lngErste, 2)
.Range(.Cells(4, intSpalte), .Cells(lngLetzte, intSpalte + 2)).Cells.SpecialCells(xlCellTypeVisible).Copy _
Worksheets("Kundenzeiten").Cells(lngErste, 3)
lngErste = lngErste + .AutoFilter.Range.Columns(1).SpecialCells(xlCellTypeVisible).Count - 1
.AutoFilter.ShowAllData
Next intSpalte
.Range(.Cells(3, 2), .Cells(lngLetzte, 15)).AutoFilter
End With
End Sub


Ob der Code schneller ist als deiner habe ich allerdings nicht getestet.

<hr width="20%" align="left"><img src="http://excel-inn.de/images/grusz.gif" height=35" align="left" alt="Grußformel"><a href="http://excel-inn.de/"><img border="0" src="http://excel-inn.de/images/logo1.gif" height=35" align="middle" alt="Beverly's Excel - Inn"></a>

klin89
20.08.2017, 19:59
Re Saerdna61,

Option Explicit
Sub transpose()
Dim a, b(), i As Long, j As Long, n As Long
With Sheets("Gesamtjahr").Range("a2").CurrentRegion
a = .Value
ReDim b(1 To (UBound(a, 1) * (UBound(a, 2) - 3) / 3), 1 To 5)
End With
For j = 3 To UBound(a, 2) - 1 Step 3
For i = 3 To UBound(a, 1)
If Not IsEmpty(a(i, j)) Then
n = n + 1
b(n, 1) = a(i, 1)
b(n, 2) = a(i, 2)
b(n, 3) = a(i, j)
b(n, 4) = a(i, j + 1)
b(n, 5) = a(i, j + 2)
End If
Next
Next
Application.ScreenUpdating = True
With Sheets("Kundenzeiten").Range("a1")
.CurrentRegion.Clear
With .Resize(n, UBound(b, 2))
.Value = b
.Font.Name = "calibri"
.Font.Size = 10
.VerticalAlignment = xlCenter
.Borders(xlInsideVertical).Weight = xlThin
.BorderAround Weight:=xlThin
.Columns.AutoFit
End With
.Parent.Activate
End With
Application.ScreenUpdating = True
End Sub
klin89