AW: Kannste den Code posten? o.T.
18.05.2011 10:13:37
abu
Hi Marcl,
hier der Code. Am Ende rufe ich die Funktion Suchen auf, die Zeile durchlaeuft er einfach ohne in die Funktion zu gehen. Testhalber habe ich auch andere getestet, macht er auch nicht...
Gruss
abu
Sub Calculate_Click()
Dim start, startz, ende, i, k, z, y, x, v, zaehler As Integer
Dim daten(), ldaten()
Dim rechne, bruecke, test, tpicks, tpeace As Double
Dim btest As Long
zaehler = 0
For i = 1 To 12
If Me.Controls("OptionButton" & i).Value = True Then zaehler = 1
Next
If zaehler = 0 Then
MsgBox "Please choose month and try again!"
Unload Me
Exit Sub
End If
start = 0
i = 1
Do Until start 0
If Me.Controls("OptionButton" & i).Value = True Then start = i
i = i + 1
Loop
ende = 0
i = 12
Do Until ende 0
If Me.Controls("OptionButton" & i).Value = True Then ende = i
i = i - 1
Loop
zaehler = 0
For i = start To ende
If Me.Controls("OptionButton" & i).Value = False Then zaehler = 1
Next
If zaehler = 1 Or start = ende Then
MsgBox "Please check the period!"
Unload Me
Exit Sub
End If
If OptionButton13.Value = True Then
For i = start To ende
If Me.Controls("TextBox" & i).Value = "" Then
MsgBox "Please check weighting!"
Unload Me
Exit Sub
End If
Next
End If
With Worksheets("Data")
ReDim daten(3 To leZeile, 1 To ((ende - start + 3) + 3))
startz = start
For i = 3 To leZeile
daten(i, 1) = .Cells(i, 1).Value
If OptionButton13.Value = True Then
For k = 2 To (ende - start + 2)
daten(i, k) = .Cells(i, ((8 * startz) + 1)).Value
tpicks = tpicks + .Cells(i, ((8 * startz) - 5)).Value 'addiere _
total picks der monate
tpeace = tpeace + .Cells(i, ((8 * startz) - 2)).Value 'addiere _
total peace der monate
rechne = .Cells(i, ((8 * startz) + 1)).Value * Me.Controls("TextBox" & _
startz).Value
bruecke = bruecke + rechne
startz = startz + 1
Next
daten(i, k) = bruecke
daten(i, k + 1) = tpicks
daten(i, k + 2) = tpeace
daten(i, k + 3) = WorksheetFunction.RoundUp(.Cells(i, ((8 * (startz - 1)) - 2)). _
Value / 20, 0)
bruecke = 0
tpicks = 0
tpeace = 0
startz = start
Else
For k = 2 To (ende - start + 2)
daten(i, k) = .Cells(i, ((8 * startz) + 1)).Value
tpicks = tpicks + .Cells(i, ((8 * startz) - 5)).Value 'addiere _
total picks der monate
tpeace = tpeace + .Cells(i, ((8 * startz) - 2)).Value 'addiere _
total peace der monate
rechne = .Cells(i, ((8 * startz) + 1)).Value
bruecke = bruecke + rechne
startz = startz + 1
Next
daten(i, k) = bruecke / (ende - start + 1)
daten(i, k + 1) = tpicks
daten(i, k + 2) = tpeace
daten(i, k + 3) = WorksheetFunction.RoundUp(.Cells(i, ((8 * (startz - 1)) - 2)). _
Value / 20, 0)
bruecke = 0
tpicks = 0
tpeace = 0
startz = start
End If
Next
End With
Application.DisplayAlerts = False
If WorkSheetExists("ABC Analysis Piece") Then Sheets("ABC Analysis Piece").Delete
Application.DisplayAlerts = True
Sheets.Add.Name = "ABC Analysis Piece"
With Worksheets("ABC Analysis Piece")
.Cells(1, 1).Value = "ABC Analysis Piece Pick - Period: " & start & " - " & ende
.Cells(20, 1).Value = "ID"
.Cells(20, 2).Value = "STORER"
.Cells(20, 3).Value = "PART NUMBER"
.Cells(20, 4).Value = "PART DESCRIPTION"
.Cells(20, 5).Value = "PART FAMILY"
.Cells(20, 6).Value = "TOTAL NUMBER OF PICKS"
.Cells(20, 7).Value = "TOTAL NUMBER OF PIECES"
.Cells(20, 8).Value = "PAVERAGE NUMBER OF PIECES IN PICKS PER DAY (Month 3)"
.Cells(20, 9).Value = "CUMULATIVE PERCENTAGE PICKS"
.Cells(20, 10).Value = "ABC_CLASS"
.Cells(20, 11).Value = "PICK_AREA"
.Cells(20, 12).Value = "PICK_LOCATION"
.Cells(20, 13).Value = "MAX_REPL_NUMBER_OF_LOC"
.Cells(20, 14).Value = "MIN_REPL_QTY"
.Cells(20, 15).Value = "MAX_REPL_QTY"
.Cells(20, 16).Value = "PALLET_QTY"
.Cells(20, 17).Value = "CASE_QTY"
.Cells(20, 18).Value = "EMERG-PCK"
.Cells(20, 19).Value = "NO PICKAREA"
.Cells(20, 20).Value = "PICKAA"
.Cells(20, 21).Value = "PICKA"
.Cells(20, 22).Value = "PICKB"
.Cells(20, 23).Value = "PICKC"
.Cells(20, 24).Value = "SHELVEAREA"
.Cells(20, 25).Value = "GRAND TOTAL"
y = 3
For i = 3 To UBound(daten)
.Cells(i + 18, 3).Value = daten(y, 1)
.Cells(i + 18, 6).Value = daten(y, k + 1)
.Cells(i + 18, 7).Value = daten(y, k + 2)
.Cells(i + 18, 8).Value = daten(y, k + 3)
.Cells(i + 18, 9).Value = daten(y, k)
If daten(y, k) = 40 And daten(y, k) = 80 And daten(y, k) = 95 Then .Cells(i + 18, 10).Value = "C"
y = y + 1
Next
Unload Me
End With
ReDim ldaten(1 To UBound(daten) - 2, 1 To 16)
v = 1
x = 1
Worksheets("Stock report").Activate
With Worksheets("Stock report")
Cells(1, 1).Select
Selection.AutoFilter
End With
Worksheets("ABC Analysis Piece").Activate
With Worksheets("ABC Analysis Piece")
Range("A20:Y" & UBound(daten) + 18).Sort Key1:=Range("I21"), Order1:=xlAscending, _
Header:= _
xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
For i = 21 To (UBound(ldaten) + 20)
ldaten(x, 1) = .Cells(i, 3).Value
x = x + 1
Next
'btest = Suchen(ldaten(1, 1))
'btest = leZeile
'btest = leZeiletest
For i = 1 To UBound(ldaten)
If Suchen(ldaten(i, 1)) -1 Then
Selection.AutoFilter Field:=1, Criteria1:=ldaten(i, 1)
End If
Next
End With
End Sub
Private Sub Cancel_Click()
Unload Me
End Sub
Function leZeile() As Long
leZeile = CLng(Range(Worksheets("Data").Range("A:A").Find(what:="*", _
After:=Range("A65536"), LookIn:=xlValues, LookAt:=xlWhole, _
SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Address).Row)
End Function
Function leZeiletest() As Long
leZeiletest = CLng(Range(Worksheets("ABC Analysis Piece").Range("A:A").Find(what:="*", _
After:=Range("A65536"), LookIn:=xlValues, LookAt:=xlWhole, _
SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Address).Row)
End Function
Public Function WorkSheetExists(ByVal WorksheetName As String) As Boolean
On Error Resume Next
WorkSheetExists = (Sheets(WorksheetName).Name "")
On Error GoTo 0
End Function
Function Suchen(Suchbegriff)
Dim Bereich As Range
Set Bereich = Sheets("Stock report").Columns("A:A").Find(Suchbegriff, LookAt:=xlPart, _
LookIn:=xlFormulas)
If Bereich Is Nothing Then
Suchen = -1
Else
Suchen = Bereich.Row
End If
End Function