VBA Code langsam trotz array
17.04.2007 13:07:23
chris
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.!