Code entspecken?
Jan
ich habe einen Code "geschrieben" der in festgelegten Spalten eines Datenblatts fehlende Daten interpoliert. Es geht um Zählerstände von Wärme- bzw. Stromzählern und Lücken zwischen den Zählerständen die automatisch "aufgefüllt" werden sollen, also die Differenz der Zählerstände wird durch die Anzahl der leeren Zellen geteilt und dann aufaddiert, sodass der Zählerstand linear ansteigt. Neben der Zelle mit dem Zählerstand ist bei den meisten Zellen noch eine Spalte mit der aktuellen Leistung, die auf ähnliche Weise interpoliert werden soll, also die Differenz zwischen zwei Zählerständen multipliziert mit 30 (von kWh auf kW umgerechnet bei einer Zwitdifferenz von 2 Minuten, also "eigentlich *2 /60). Die Spalte B ist die Spalte mit der Datums- und Uhrzeitabgabe die keine Lücken aufweist, die ganze Chose soll also solange durchgeführt werden, bis keine Messungen mehr erfolgen und somit kein Wert mehr in der Datumsspalte steht.
Leider Gottes bin ich VBA-technisch noch sehr unbedarft und habe einen Code erstellt, der meines Erachtens nach viel zu umständlich ist. Ich habe schon versucht das ganze etwas zu verschlanken, war leider nicht von Erfolg gekrönt. Vielleicht hat jemand von euch einen Ratschlag für mich? Vorallem dieses ständige Copy/Paste des gleichen Codes für verschiedene Spalten würde ich gerne loswerden.
Hat jemand ein paar Ratschläge für mich?
LG,
Jan
Hier eine Beispieldatei : https://www.herber.de/bbs/user/68710.xlsm
Hier der Code:
Sub LinFuell()
' LinFuell Makro
' Auffüllen von Leerzeilen durch lineare Interpolation
Application.ScreenUpdating = False
Do Until Cells(Reihe + 1, 2) = ""
' Anzahl Leerzeilen bestimmen
Range("E3").Activate 'Q-EWS
Spalte = ActiveCell.Column
Selection.End(xlDown).Select
LetzterWert = ActiveCell.Value
LetzterWertZeile = ActiveCell.Row
ActiveCell.Offset(1, 0).Select
Startzeile = ActiveCell.Row
Selection.End(xlDown).Select
ErsterWert = ActiveCell.Value
NächsteSuchZeile = ActiveCell.Row
Endzeile = ActiveCell.Row - 1
Luecke = (Endzeile - Startzeile) + 2
Delta = (ErsterWert - LetzterWert) / Luecke
' Leerzeilen auffüllen (lin. Interpolation)
Cells(Startzeile, Spalte).Select
ActiveCell.FormulaR1C1 = "=R[-1]C+ " & Delta & " "
ActiveCell.Copy
Range(Cells(Startzeile, Spalte), Cells(Endzeile, Spalte)).Select
ActiveSheet.Paste
Selection.Interior.ColorIndex = 35
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("D3").Activate 'P_EWS
Spalte = ActiveCell.Column
Cells(Startzeile, Spalte).Select
ActiveCell.Value = Delta * 30
ActiveCell.Copy
Range(Cells(Startzeile, Spalte), Cells(Endzeile, Spalte)).Select
ActiveSheet.Paste
Selection.Interior.ColorIndex = 36
Range("K3").Activate 'Q_LK
Spalte = ActiveCell.Column
Selection.End(xlDown).Select
LetzterWert = ActiveCell.Value
Selection.End(xlDown).Select
ErsterWert = ActiveCell.Value
Delta = (ErsterWert - LetzterWert) / Luecke
Cells(Startzeile, Spalte).Select
ActiveCell.FormulaR1C1 = "=R[-1]C+ " & Delta & " "
ActiveCell.Copy
Range(Cells(Startzeile, Spalte), Cells(Endzeile, Spalte)).Select
ActiveSheet.Paste
Selection.Interior.ColorIndex = 35
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("J3").Activate 'P_LK
Spalte = ActiveCell.Column
Cells(Startzeile, Spalte).Select
ActiveCell.Value = Delta * 30
ActiveCell.Copy
Range(Cells(Startzeile, Spalte), Cells(Endzeile, Spalte)).Select
ActiveSheet.Paste
Selection.Interior.ColorIndex = 36Range("BF" & Startzeile - 1, "BZ" & Startzeile - 1). _
Select
Selection.AutoFill Destination:=Range("BF" & Startzeile - 1, "CA" & Endzeile), Type:= _
xlFillDefault
Range("BF" & Startzeile, "CA" & Endzeile).Interior.ColorIndex = 6
Cells(NächsteSuchZeile, 5).Activate
Selection.End(xlDown).Select
Reihe = ActiveCell.Row
Loop
Application.ScreenUpdating = True
End Sub