Live-Forum - Die aktuellen Beiträge
Datum
Titel
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
860to864
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
860to864
860to864
Aktuelles Verzeichnis
Verzeichnis Index
Verzeichnis Index
Übersicht Verzeichnisse
Inhaltsverzeichnis

VBA Code langsam trotz array

VBA Code langsam trotz array
17.04.2007 13:07:23
chris
Hallo VBA Profis,
bei mir geht es heute mal um eine code optimierung bei der ich hilfe benötige..
habe ein ganz "normales" Makro geschrieben.. das aber komischerweiße lange braucht..
Würde mich bei diesem einen modul nicht stören aber muss es öfter kopieren udn nur zeilen ändern.
Der code läuft auch ziemlich schnell bis ab hier dauert es lange::
'ab hier !!!->
'Werte eintragen nacht
y = 0
wo = 226
For xx = 1 To 10
If nacht(xx) "" Then
y = y + 1
If y > 4 Then Exit For
Cells(wo, x) = typ(xx)
Cells(wo, x + 1) = nacht(xx)
wo = wo + 2
Else
End If
Next
'Werte eintragen früh
y = 0
wo = 226
For xx = 1 To 10
If frue(xx) "" Then
y = y + 1
If y > 4 Then Exit For
Cells(wo, x + 2) = typ(xx)
Cells(wo, x + 3) = frue(xx)
wo = wo + 2
Else
End If
Next
'und der rest.............
'------------------------------

Sub uebertragen_l3_1()
Dim frue(10)
Dim spaet(10)
Dim nacht(10)
Dim typ(10)
Dim schicht As String
schicht = UCase(InputBox("Frühsschicht = Schicht1  oder Schicht2 "))
If schicht  "1" And schicht  "2" Then
MsgBox ("Warnung abbruch Bitte nur 1 oder 2 eingeben !"), vbCritical, "Warnung"
Exit Sub
End If
If schicht = "1" Then
f = 9
s = 10
End If
If schicht = "2" Then
f = 10
s = 9
End If
'Typen eintragen
For x = 1 To 10
typ(x) = Cells(x + 2, 8)
y = y + 1
Next
'zu übertragene Daten eintragen in Array
'früh
y = 0
For x = 1 To 10
If Cells(x + 2, f)  "" Then
If y >= 4 Then
MsgBox ("Warnung es gabe mehere Umstellungen NUR4 Werte eingetragen... Bitte prüfen"), , "früh"
Exit For
End If
frue(x) = Cells(x + 2, f)
y = y + 1
End If
Next
'spaet
y = 0
For x = 1 To 10
If Cells(x + 2, s)  "" Then
If y >= 4 Then
MsgBox ("Warnung es gabe mehere Umstellungen NUR4 Werte eingetragen... bitte prüfen"), , "spät"
Exit For
End If
spaet(x) = Cells(x + 2, s)
y = y + 1
End If
Next
'nacht
y = 0
For x = 1 To 10
If Cells(x + 2, 11)  "" Then
If y >= 4 Then
MsgBox ("Warnung es gabe mehere Umstellungen NUR4 Werte eingetragen... bitte prüfen"), , "nacht" _
Exit For
End If
nacht(x) = Cells(x + 2, 11)
y = y + 1
End If
Next
Application.ScreenUpdating = False
akt_sheet_name_monat = MonthName(Month(Cells(1, 3)))
gesdate = Cells(1, 3)
'öffnet MAE
Workbooks.Open ("c:\test.xls")
ActiveWorkbook.Worksheets(akt_sheet_name_monat).Select
' richtige typen tauschen in schon gefülltest array
z = UBound(typ())
lz = Worksheets("Daten").Cells(Rows.Count, 1).End(xlUp).Row
For ii = 0 To 10
For i = 3 To z
ges = typ(ii)
If Worksheets("Daten").Cells(i, 3) = ges Then
typ(ii) = Worksheets("daten").Cells(i, 1)
Exit For
Else
End If
Next
Next
For x = 4 To 200
such = Cells(6, x)
If Cells(6, x) = gesdate Then
Exit For
Else
End If
Next
'ab hier !!!->
'Werte eintragen nacht
y = 0
wo = 226
For xx = 1 To 10
If nacht(xx)  "" Then
y = y + 1
If y > 4 Then Exit For
Cells(wo, x) = typ(xx)
Cells(wo, x + 1) = nacht(xx)
wo = wo + 2
Else
End If
Next
'Werte eintragen früh
y = 0
wo = 226
For xx = 1 To 10
If frue(xx)  "" Then
y = y + 1
If y > 4 Then Exit For
Cells(wo, x + 2) = typ(xx)
Cells(wo, x + 3) = frue(xx)
wo = wo + 2
Else
End If
Next
'Werte eintragen spät
y = 0
wo = 226
For xx = 1 To 10
If spaet(xx)  "" Then
y = y + 1
If y > 4 Then Exit For
Cells(wo, x + 4) = typ(xx)
Cells(wo, x + 5) = spaet(xx)
wo = wo + 2
Else
End If
Next
Application.ScreenUpdating = True
MsgBox ("abgeschlossen"), vbInformation, "Info"
End Sub


ich sage schon im vorraus vielen Dank für eure Hilfe.!

2
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: VBA Code langsam trotz array
21.04.2007 12:17:03
Gerd
Hallo Chris,
"Select" verträgt sich glaub' ich nicht so gut mit "ScreenUpdating=False".
Wenn oben auf 4 beschänkt wird, ist unten die Prüfung auf 4 entbehrlich.
Die Argumente der Find-Methode musst noch hinzufügen.
Und bei der Messagebox kannst ebenfalls noch feilen.
Gruß Gerd

Sub Umschichten()
Dim f As Integer, s As Integer, x As Integer, a As Integer, b As Integer, c As Integer
Dim wo As Long, Schicht As String, gesdate As Date, akt_sheet_name_monat As String, strMsg As  _
String
Dim frueh(), spaet(), nacht(), arrTyp(1 To 10)
Schicht = InputBox("Fühschicht = 1, sonst 2")
If Schicht  1 And Schicht  2 Then MsgBox "War nix": Exit Sub
f = 8 + CInt(Schicht)
s = 11 - CInt(Schicht)
x = 10
ReDim frueh(0 To x): ReDim spaet(0 To x): ReDim nacht(0 To x)
With ActiveWorkbook.ActiveSheet ' ggf. ändern
'Typen eintragen
For x = 1 To 10
arrTyp(x) = .Cells(x + 2, 8)
Next
'frueh,spaet,nacht in Arrays eintragen
For x = 1 To 10
If .Cells(x + 2, f)  "" Then frueh(a + 1) = .cell(x + 2, f): a = a + 1
If .Cells(x + 2, s)  "" Then spaet(b + 1) = .cell(x + 2, s): b = b + 1
If .Cells(x + 2, 11)  "" Then nacht(b + 1) = .cell(x + 2, 11): c = c + 1
Next
On Error Resume Next
ReDim Preserve frueh(0 To a): ReDim Preserve spaet(0 To b): ReDim Preserve nacht(0 To c)
On Error GoTo 0
If UBound(frueh) + UBound(spaet) + UBound(nacht) = 0 Then MsgBox "Keine Umstellungen": Exit  _
Sub
If UBound(frueh) > 4 Then strMsg = strMsg & UBound(frueh) & "Umstellungen früh "
If UBound(spaet) > 4 Then strMsg = strMsg & UBound(spaet) & "Umstellungen spät "
If UBound(nacht) > 4 Then strMsg = strMsg & UBound(nacht) & "Umstellungen nacht "
If strMsg  "" Then MsgBox strMsg: Exit Sub
gesdate = .Cells(1, 3)
akt_sheet_name_monat = MonthName(Month(.Cells(1, 3)))
End With
On Error Resume Next
If Workbooks("test.xls") Is Nothing Then Workbooks.Open ("C:\test.xls")
On Error GoTo 0
'Typentausch
For a = 1 To 10
For b = 3 To UBound(arrTyp)
If Workbooks("test.xls").Worksheets("Daten").Cells(b, 3) = arrTyp(a) Then
arrTyp(a) = Workbooks("test.xls").Worksheets("Daten").Cells(b, 1)
End If
Next
Next
With Workbooks("test.xls").Worksheets(akt_sheet_name_monat)
'Spaltensuche
x = .Range(.Cells(6, 4), .Cells(6, 200)).Find(gesdate).Column
If x = 0 Then x = 201
'Werte eintragen
wo = 226
For a = 1 To 4
If a 


Anzeige
AW: VBA Code langsam trotz array
21.04.2007 19:59:00
chris
Wow, vielen dank Gerd,
ich werde den code gleich am Montag testen !! danke und schönes WE

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige