Dynamisch lijst kunnen kiezen als input data

[bjw]

Beste allen,

Ik ben nieuw in het werken met VBA en probeer met VBA het jaar waarin een object schade door droogstand oploopt te berekenen. Dit is me, met behulp van dit fijne forum, al gelukt, maar ik probeer nu om de rij waaruit de macro de waterstanden moet halen aan te passen aan de locatie van het object. Hiervoor heb ik een locatiebepaling bij elk object gevoegd (in het voorbeeld in kolom C) die overeenkomt met een meetreeks in het tabblad "Data". Ik heb al even lopen pielen ermee en ik zat in de richting te denken van het gebruiken van Hlookup of een dubbele For loop, maar ik kom er maar niet uit. Kunnen jullie mij misschien helpen?

Bijgevoegd het voorbeeldbestand en de code die ik nu heb.

Groet,
Bram

Bekijk bijlage Voorbeeld (1).xlsm

Sub waterstanden()
Dim i As Long, L2 As Long, a, cl As Range, lCalcState As Long, _
Starttime As Double, SecondsElapsed As Double, Jaren As Integer
Application.ScreenUpdating = False
Starttime = Timer
lCalcState = Application.Calculation
Application.Calculation = xlCalculationManual
a = Worksheets("Data").Range("A1").CurrentRegion.Value
Jaren = InputBox("Na hoeveel jaar leidt droogstand tot schade?", "B.J.W. Wassenaar:", 15)
Range("K11").Value = Jaren
For Each cl In Range("D2:D6")
L2 = 0
   For i = 2 To UBound(a)
      L2 = L2 - (a(i, 2) < cl.Offset(0, -2).Value)
        If cl.Offset(0, -2).Value = "" Then
          cl = ""
        ElseIf L2 >= Jaren * 24 Then
          cl = a(i, 1)
          Exit For
        Else
          cl = Math.Round((L2 + 0.000001) / 2, 0)
        End If
   Next i
Next cl
Application.Calculation = lCalcState
SecondsElapsed = Round(Timer - Starttime, 2)
' Geluid. Vooral handig als running time lang is en je meer te doen hebt.
' Als het geluid lang is, duurt het ook langer tot de MsgBox verschijnt.
Set oVoice = CreateObject("SAPI.SpVoice")
Set oSpFileStream = CreateObject("SAPI.SpFileStream")
oSpFileStream.Open "W:\Projecten\030\08 Werkmap adviseur\Bram Wassenaar\GWS\cash-register-05.wav"
oVoice.SpeakStream oSpFileStream
oSpFileStream.Close
' oVoice.Speak "Finished Playing wave file." -> Een stem die zegt wat er tussen aanhalingstekens staat.
MsgBox "Deze code is uitgevoerd in " & SecondsElapsed & " seconden.", vbInformation + vbSystemModal, "B.J.W. Wassenaar:"
Application.ScreenUpdating = True
End Sub

 

[snb]

Zonder toeters & bellen (want te snel voor toeters en bellen)

Sub M_waterstanden_snb()
  sn = Sheet2.Cells(1).CurrentRegion
  sp = Sheet1.Range("B2:D6")
    
  y = InputBox("Na hoeveel jaar leidt droogstand tot schade?", "B.J.W. Wassenaar", 15)

  For j = 1 To UBound(sp)
    If sp(j, 2) = "" Then
      sp(j, 3) = ""
    Else
      x = 0
      For jj = 2 To UBound(sn)
        x = x - (sn(jj, 2 - (sp(j, 2) = "2-1.05")) < sp(j, 1))
        If x >= y * 24 Then Exit For
      Next
      If jj < UBound(sn) + 1 Then sp(j, 3) = sn(jj, 1)
      If jj = UBound(sn) + 1 Then sp(j, 3) = Round((x + 0.000001) / 2, 0)
    End If
  Next
    
  Sheet1.Range("B2:D6") = sp
  Sheet1.Cells(11, 11) = y
End Sub

 

[bjw]

Bedankt voor je reactie snb. Als het getal in

x = x - (sn(jj, 2 - (sp(j, 2) = "2-1.05")) < sp(j, 1))

wordt veranderd naar de kolom die je wilt hebben rekent hij inderdaad de juiste kolom door. Dit doet hij met deze code echter niet bij de regels waar "2-1.04" staat aangegeven, hier pakt hij weer de eerste kolom met waterstanden. In mijn originele bestand heb ik 17 kolommen die op deze manier tegelijk gekozen en berekend moeten worden. Weet je misschien hoe je dat in de VBA code kan verwerken?

 

[snb]

Dan zo

sp(j,2)="2-1.05"
x = x - (sn(jj, 3 - (sp(j, 2) = "2-1.05")) < sp(j, 1))
x = x - (sn(jj, 3 - -1 )<sp(j,1))
x = x - (sn(jj, 4 )<sp(j,1))

sn(jj,4) is de vierde kolom

sp(j,2)="2-1.04"
x = x - (sn(jj, 3 - (sp(j, 2) = "2-1.05")) < sp(j, 1))
x = x - (sn(jj, 3 - 0 )<sp(j,1))
x = x - (sn(jj, 3 )<sp(j,1))

sn(jj,3) is de derde kolom

Meer algemeen (je 2e vraag):

Sub M_waterstanden_snb()
   sn = Sheet2.Cells(1).CurrentRegion
   sp = Sheet1.Range("B2:D6")
   sq = Application.Index(sn, 1)
   
   y = InputBox("Na hoeveel jaar leidt droogstand tot schade?", "B.J.W. Wassenaar", 15)

    For j = 1 To UBound(sp)
        If sp(j, 2) = "" Then
          sp(j, 3) = ""
        Else
            x = 0
            x1 = Application.Match(sp(j, 2), sq, 0)
            For jj = 2 To UBound(sn)
                x = x - (sn(jj, x1) < sp(j, 1))
                If x >= 24 * y Then Exit For
            Next
            If jj < UBound(sn) + 1 Then sp(j, 3) = sn(jj, 1)
            If jj = UBound(sn) + 1 Then sp(j, 3) = Round((x + 10 ^ -6) / 2, 0)
        End If
    Next
    
    Sheet1.Range("B2:D6") = sp
    Sheet1.Cells(11, 11) = y
End Sub

 

[bjw]

Bedankt voor het meedenken. Nog een kleine opmerking op je vorige bericht:

sp(j,2)="2-1.05"
x = x - (sn(jj, 3 - (sp(j, 2) = "2-1.05")) < sp(j, 1))
x = x - (sn(jj, 3 - -1 )<sp(j,1))
x = x - (sn(jj, 4 )<sp(j,1))

sn(jj,4) is de vierde kolom

sp(j,2)="2-1.04"
x = x - (sn(jj, 3 - (sp(j, 2) = "2-1.05")) < sp(j, 1))
x = x - (sn(jj, 3 - 0 )<sp(j,1))
x = x - (sn(jj, 3 )<sp(j,1))

sn(jj,3) is de derde kolom

waarbij in het voorbeeld natuurlijk "2-1.04" hoort te staat. Typfoutje, kan gebeuren

Wat betreft de meer algemene oplossing:
Als ik deze code uitvoer pakt de code alleen de eerste match die hij kan vinden, in het geval van het voorbeeld dus 2-1.04. Kan dit nog omzeild worden? Moet x1 bijvoorbeeld aan het eind van elke loop gecleared worden o.i.d.?

 

[snb]

1. Ik zie geen typefout

2. per 'regel' in B2 : D6 hoeft er maar 1 keer gezocht te worden. nl. de waarde van C2, c3, c4 c5 c6
die kolom geldt voor de hele vergelijking van alle waarden in array sn ten opzichte van de waarde in B2,b3,b4.b5 en B6

3. als je F8 gebruikt zul je zien dat wanneer in C2:C6 "2-1.05" staat de waarde van x1 4 is en als c2:C6 de waarde "2-1.04" heeft x1 de waarde 3 krijgt.

4. als de invoer in C2:C6 anders is dan in werkblad 'data' in rij 1 is er nooit sprake van een match.

5. Als ik niet kan zien waarop je de code toepast, kan ik ook niets beoordelen.

 

[bjw]

1. Je hebt helemaal gelijk, wat stom van me. Laten we het foute typefoutaanname noemen.

5. De code is toegepast op het voorbeeldbestand dat in mijn eerste post is bijgevoegd

2. t/m 4. Ik zie nu wat er bij mij mis is gegaan. Doordat de uiteindelijke output in het voorbeeldbestand bij objecten met "2-1.05" 0 was dacht ik dat de code niet werkte. Hij werkte wel: de output was 0 en de waarden die als input worden gegeven waren te hoog om andere output te krijgen. Zoals ik al zei: nieuw met VBA...

De code doet het nu perfect en met wat kleine aanpassingen kan ik hem ook voor mijn originele bestand gebruiken. Weer wat geleerd vandaag. Hartstikke bedankt voor de hulp en ik zal de vraag op opgelost zetten!