Loop opnieuw starten wanneer 'entry' kolum A veranderd

[Kickk05]

Hallo iedereen,

Ik ben bezig met het continu maken van intervallen met kleine stapjes. De database is zo ingedeeld dat de 'naam' in Kolom A staat met de bijbehorende intervallen in kolom B en C (zie plaatje).



Nu is het mij al gelukt om in een tweede worksheet de intervallen van 'Henk' continu te maken.
Ik wil nu echter ervoor zorgen dat mijn VBA code detecteert dat een nieuwe naam in kolom A ook betekent dat hij weer op '0' moet beginnen en dezelfde loop moet doen, liefst in een nieuwe worksheet.

Dit is de code die ik tot nu toe heb:

Sub IntervalToSample()
Dim Cancelled, OldStatusbar As Boolean
Dim NOI, TI, TS, DOF, i, j, Samples, SII As Integer
Dim Counter As Long
Dim Top, Base, Inc, TopI, BaseI As Double
Dim WellN As String

OldStatusbar = Application.DisplayStatusBar

'---------------->>> Data Definition Section <<<-----------------------
DOF = 5
Counter = 0
SII = 0
WellN = Sheets("Data").Cells(DOF + 1, 1)
Top = Sheets("Data").Cells(DOF + 1, 2)
Inc = Sheets("Samples").Cells(1, 6)
Sheets("Data").Select
Range("A1").End(xlDown).Select
TI = ActiveCell.Row - DOF
Base = Sheets("Data").Cells(ActiveCell.Row, 3)
TS = Int((Base - Top) / Inc) + 2

Sheets("Samples").Cells(2, 6) = WellN
Sheets("Samples").Cells(3, 6) = Top
Sheets("Samples").Cells(4, 6) = Base
Sheets("Samples").Cells(5, 6) = TI
Sheets("Samples").Cells(6, 6) = TS

Application.ScreenUpdating = False
Application.StatusBar = True

'---------------->>> Begin of calculation loop. Everything after this line is meant for the calculation. <<<-----------------------
If Not Cancelled Then

For i = 1 To TI
TopI = Sheets("Data").Cells(i + DOF, 2)
BaseI = Sheets("Data").Cells(i + DOF, 3)
Samples = CInt((BaseI - TopI) / Inc)
Sheets("Samples").Cells(i, 11) = Samples
Application.StatusBar = i
Next i

For i = 1 To TS
Sheets("Samples").Cells(i, 8) = Top + (i - 1) * Inc
Next i

For i = 1 To TI
SII = Sheets("Samples").Cells(i, 11)
If i = TI Then SII = SII + 1
For j = 1 To SII
Counter = Counter + 1
Sheets("Samples").Cells(Counter, 9) = Sheets("Data").Cells(i + DOF, 13)
Next j
Next i

End If 'If not Cancelled
'---------------->>> End of calculation loop. Everything after this line is after the calculation is done. <<<-----------------------

Range("A1").Select
ActiveWindow.ScrollRow = Range("A1").Row
Application.ScreenUpdating = True
Application.DisplayStatusBar = OldStatusbar
End Sub

 

[VenA]

Plaats en de code tussen codetags en ipv een plaatje een Excelbestand. Dit is totaal onleesbaar!

 

[Kickk05]

Thank you for your reaction venA,

I would like to ReSample intervals. And put a classification next to the resampled intervals. I already managed to do this for 1 Name (PIET). Now I want to do the same with a second Name (HENK) in the database. For this I need the code to start a new loop, when a new name is found in the database (same as finding a '0' as top). I would like to have the new results in a new workbook with the name HENK. If possible I would like to have the results of PIET also in a new workbook with the name PIET.
I put my excel file in the appendix.

Bekijk bijlage ReSample intervals with classification..xlsm

Sub IntervalToSample()
    Dim Cancelled, OldStatusbar As Boolean
    Dim NOI, TI, TS, DOF, i, j, Samples, SII As Integer
    Dim Counter, Bounter As Long
    Dim Top, Base, Inc, TopI, BaseI As Double
    Dim Name As String

    OldStatusbar = Application.DisplayStatusBar
    
 '---------------->>> Data Definition Section <<<-----------------------
    DOF = 5
    Counter = 0
    Bounter = 0
    SII = 0
    Name = Sheets("Data").Cells(DOF + 1, 1)
    Top = Sheets("Data").Cells(DOF + 1, 2)
    Inc = Sheets("Samples").Cells(1, 6)
    Sheets("Data").Select
    Range("A1").End(xlDown).Select
    TI = ActiveCell.Row - DOF
    Base = Sheets("Data").Cells(ActiveCell.Row, 3)
    TS = Int((Base - Top) / Inc) + 2
    
    Sheets("Samples").Cells(2, 6) = Name
    Sheets("Samples").Cells(3, 6) = Top
    Sheets("Samples").Cells(4, 6) = Base
    Sheets("Samples").Cells(5, 6) = TI
    Sheets("Samples").Cells(6, 6) = TS
        
    Application.ScreenUpdating = False
    Application.StatusBar = True
    
 '---------------->>> Begin of calculation loop. Everything after this line is meant for the calculation. <<<-----------------------
    If Not Cancelled Then
       
      For i = 1 To TI
        TopI = Sheets("Data").Cells(i + DOF, 2)
        BaseI = Sheets("Data").Cells(i + DOF, 3)
        Samples = CInt((BaseI - TopI) / Inc)
        Sheets("Samples").Cells(i, 12) = Samples
        Application.StatusBar = i
      Next i
      
      For i = 1 To TS
       Sheets("Samples").Cells(i, 8) = Top + (i - 1) * Inc
      Next i
      
      For i = 1 To TI
        SII = Sheets("Samples").Cells(i, 12)
        If i = TI Then SII = SII + 1
        For j = 1 To SII
          Counter = Counter + 1
          Sheets("Samples").Cells(Counter, 9) = Sheets("Data").Cells(i + DOF, 13)
          Bounter = Bounter + 1
          Sheets("Samples").Cells(Bounter, 10) = Sheets("Data").Cells(i + DOF, 16)
         Next j
      Next i
      
    End If                                    'If not Cancelled
'---------------->>> End of calculation loop. Everything after this line is after the calculation is done. <<<-----------------------
    
    Range("A1").Select
    ActiveWindow.ScrollRow = Range("A1").Row
    
    Application.ScreenUpdating = True
    Application.DisplayStatusBar = OldStatusbar
End Sub