Code umschreiben?
27.11.2006 11:43:03
Metman
ich hab ein Code das mir Werte auf einem anderen Tabellenblatt sucht, dann die werte mit einem offset (-2,0) in einem Array speichert. Das array wird mit 6 Werten gefüllt.
Hier mal mein Code, ich möchte das aber in verkürzter Form als schleife haben, kriege das nicht hin
Sub zykluszeit_erfassen()
Dim rngFindID As Object, ersteAdresse$
Dim zeilen_max As Long, i As Long
Dim Identifier As String
Dim sheetDB As Worksheet
Dim sheetImp As Worksheet
Dim rangeImpD As Range
Dim firstAddress As String
Dim arrFeld(6) As Variant
Set sheetDB = Worksheets("Datenbasis")
Set sheetImp = Worksheets("imported")
Set rangeImpD = sheetImp.Columns(4)
zeilen_max = sheetDB.Cells(65536, 2).End(xlUp).Row
For i = 8 To zeilen_max
Identifier = sheetDB.Cells(i, 2)
If Identifier <> "" Then
With Worksheets("imported").Range("D:D")
Set rngFindID = .Find(Identifier)
If Not rngFindID Is Nothing Then
ersteAdresse = rngFindID.Address
arrFeld(0) = rngFindID.Offset(0, -2)
sheetDB.Cells(i, 6).ClearContents
Do
Set rngFindID = .FindNext(rngFindID)
If Not rngFindID.Address = ersteAdresse Then 'Exit Do
If Not rngFindID Is Nothing Then
arrFeld(1) = rngFindID.Offset(0, -2)
sheetDB.Cells(i, 6).ClearContents
Exit Do
End If
End If
Loop While Not rngFindID Is Nothing And rngFindID.Address <> ersteAdresse
Do
Set rngFindID = .FindNext(rngFindID)
If Not rngFindID.Address = ersteAdresse Then 'Exit Do
If Not rngFindID Is Nothing Then
arrFeld(2) = rngFindID.Offset(0, -2)
sheetDB.Cells(i, 6).ClearContents
Exit Do
End If
End If
Loop While Not rngFindID Is Nothing And rngFindID.Address <> ersteAdresse
Do
Set rngFindID = .FindNext(rngFindID)
If Not rngFindID.Address = ersteAdresse Then 'Exit Do
If Not rngFindID Is Nothing Then
arrFeld(3) = rngFindID.Offset(0, -2)
sheetDB.Cells(i, 6).ClearContents
Exit Do
End If
End If
Loop While Not rngFindID Is Nothing And rngFindID.Address <> ersteAdresse
Do
Set rngFindID = .FindNext(rngFindID)
If Not rngFindID.Address = ersteAdresse Then 'Exit Do
If Not rngFindID Is Nothing Then
arrFeld(4) = rngFindID.Offset(0, -2)
sheetDB.Cells(i, 6).ClearContents
Exit Do
End If
End If
Loop While Not rngFindID Is Nothing And rngFindID.Address <> ersteAdresse
Do
Set rngFindID = .FindNext(rngFindID)
If Not rngFindID.Address = ersteAdresse Then 'Exit Do
If Not rngFindID Is Nothing Then
arrFeld(5) = rngFindID.Offset(0, -2)
sheetDB.Cells(i, 6).ClearContents
Exit Do
End If
End If
Loop While Not rngFindID Is Nothing And rngFindID.Address <> ersteAdresse
sheetDB.Cells(i, 6).Value = (((arrFeld(1) - arrFeld(0)) + (arrFeld(3) - arrFeld(2)) + (arrFeld(5) - arrFeld(4))) / 3 * 1000)
sheetDB.Cells(i, 6).Interior.ColorIndex = 24
End If
End With
End If
Next i
End Sub
Hier unten wird ein Mittelwert gebildet und das wird dann in sheetdb.Cells eingeschrieben und mit farbe gefüllt. Funktioniert tadellos aber als schleifenkonstrukt kriege ich es nicht hin.
gruß
Anzeige