03. december 2003 - 22:13Der er
5 kommentarer og 1 løsning
"Langhåret" VBA hjælp til sammenlægningen af regnmåler værdier.
Hej NG.
Jeg er kommet på en svær opgave her som jeg håber der er nogen af Jer der kan hjælpe lidt med. Fra en regnmåler med datalogger får jeg 1 minutværdier af nedbørsmængden ind i et regneark.
Disse værdier skal jeg have lagt sammen på en bestemt måde således de kan bruges i et andet beregningsprogram. Her er det jeg er gået i stå, jeg mangler en rutine der kan flytte/kopiere værdierne i kolonne A og B til andre kolonner i arket. Døgnets værdierne i kolonne B skal dog deles i en eller flere perioder. 2 perioder er adskilt af mindst 60 min. uden regn, altså værdien i B er = 0.
Som vist i eksemplet ovenfor kommer første registrering 10:01 og "sidste" 10:02 derefter er der mere end 60 minutter til næste registrering og dette tæller så for en periode og værdierne i A3, A4, B3 og B4 ønskes derfor flyttet/kopieret til f. eks. kolonne G og H.
Jeg kan ikke lige hitte ud af det måske I kan. Håber I kan se problematikken ellers vend tilbage.
Public Sub TjekVand() Dim DRng As Variant, ResRng As Variant, R As Double, G As Double, I As Double A = Range("B65536").End(xlUp).Address ' finder den sidste celle der er brugt i B kolonnen B = Range("B65536").End(xlUp).Row DRng = Range("A2:" & A) ' inlæser området i A + B kolonnen Range("G1:H" & B).ClearContents ' tømmer skrive området ResRng = Range("G2:H" & B) ' området til udkrifter G + H kolonnen
For I = 1 To UBound(DRng) ' fjerner øverste 0 værdier If DRng(I, 2) > 0 Then R = I GoTo Start End If Next I
'******************************** Starter ved første værdi over 0 ***************** Start: For R = R To UBound(DRng)
If DRng(R, 2) = 0 Then For I = R To UBound(DRng) If I = UBound(DRng) Then GoTo OK ' Hvis enden er nået med 0er, afsluttes If DRng(I, 2) > 0 Then If I - R >= 60 Then ' tjekker om der 60 eller mere i træk R = I GoTo Skriv Else If I = UBound(DRng) Then GoTo OK GoTo Skriv End If End If Next I End If '************************************* *************************** Skriv:
For G = 1 To UBound(ResRng) If ResRng(G, 2) = "" Then ResRng(G, 2) = DRng(R, 2) ResRng(G, 1) = DRng(R, 1) GoTo Videre End If Next G
'************************************ ************************* Videre: Next R OK: For G = 1 To UBound(ResRng) If ResRng(G, 1) = "" Then Exit Sub Range("G" & G) = ResRng(G, 1) Range("H" & G) = ResRng(G, 2) Next
Det må jeg sige her har du virkelig gjort et flot stykke arbejde. Der er dog en lille hage. Jeg fik vist ikke udtrykt mig rigtigt i spørgsmålet, men mit egnetlige ønske var at "første" periode skulle placeres i kolonne G og H, "anden" periode placeres i kolonne I og J osv. I den fine kode du har lavet kommer de fortløbende efter hinanden. Kunne evt. komme med et par hints til det?
Nu kan den klare 9 perioder, hvis der skal være flere, så giv lige besked
Public Sub TjekVand() Dim DRng As Variant, ResRng As Variant, R As Double, G As Double, I As Double, K As Integer A = Range("B65536").End(xlUp).Address ' finder den sidste celle der er brugt i B kolonnen B = Range("B65536").End(xlUp).Row DRng = Range("A2:" & A) ' inlæser området i A + B kolonnen Range("G1:Y" & B).ClearContents ' tømmer skrive området ResRng = Range("G2:Y" & B) ' området til udkrifter G + H kolonnen K = 1 For I = 1 To UBound(DRng) ' fjerner øverste 0 værdier If DRng(I, 2) > 0 Then R = I GoTo Start End If Next I
'******************************** Starter ved første værdi over 0 ***************** Start: For R = R To UBound(DRng)
If DRng(R, 2) = 0 Then For I = R To UBound(DRng) If I = UBound(DRng) Then GoTo OK ' Hvis enden er nået med 0er, afsluttes If DRng(I, 2) > 0 Then If I - R >= 60 Then ' tjekker om der 60 eller mere i træk R = I K = K + 2 GoTo Skriv Else If I = UBound(DRng) Then GoTo OK GoTo Skriv End If End If Next I End If '************************************* *************************** Skriv:
For G = 1 To UBound(ResRng) If ResRng(G, K + 1) = "" Then ResRng(G, K + 1) = DRng(R, 2) ResRng(G, K) = DRng(R, 1) GoTo Videre End If Next G
'************************************ ************************* Videre: Next R OK: For H = 1 To K For G = 1 To UBound(ResRng) If ResRng(G, H) = "" Then GoTo NyGruppe Cells(G, H + 6) = ResRng(G, H) Cells(G, H + 7) = ResRng(G, H + 1) Next NyGruppe: Next End Sub
En ny, den udvider sig til flere serier efter behov
Public Sub TjekVand() Dim DRng() As Variant, ResRng As Variant, R As Double, G As Double, I As Double, K As Integer A = Range("B65536").End(xlUp).Address ' finder den sidste celle der er brugt i B kolonnen B = Range("B65536").End(xlUp).Row DRng = Range("A2:" & A) ' inlæser området i A + B kolonnen ReDim ResRng(B, 2) 'Dim af udlæsnings område K = 0 For I = 1 To UBound(DRng) ' fjerner øverste 0 værdier If DRng(I, 2) > 0 Then R = I GoTo Start End If Next I
'******************************** Starter ved første værdi over 0 ***************** Start: For R = R To UBound(DRng)
If DRng(R, 2) = 0 Then For I = R To UBound(DRng) If I = UBound(DRng) Then GoTo OK ' Hvis enden er nået med 0er, afsluttes If DRng(I, 2) > 0 Then If I - R >= 60 Then ' tjekker om der 60 eller mere i træk R = I K = K + 2 ReDim Preserve ResRng(B, K + 2) 'ReDim af udlæsnings område (flere kolonner) GoTo Skriv Else If I = UBound(DRng) Then GoTo OK GoTo Skriv End If End If Next I End If '************************************* *************************** Skriv:
For G = 1 To UBound(ResRng) If ResRng(G, K + 1) = "" Then ResRng(G, K + 1) = DRng(R, 2) ResRng(G, K) = DRng(R, 1) GoTo Videre End If Next G
'************************************ ************************* Videre: Next R OK: For H = 0 To K Step 2 For G = 1 To UBound(ResRng) If ResRng(G, H) = "" Then GoTo NySerie Cells(G, H + 7) = ResRng(G, H) ' starter i kolonne G Cells(G, H + 8) = ResRng(G, H + 1) Next NySerie: Next End Sub
Tilladte BB-code-tags: [b]fed[/b] [i]kursiv[/i] [u]understreget[/u] Web- og emailadresser omdannes automatisk til links. Der sættes "nofollow" på alle links.
