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ß