間隔が0から始まるときに新しいループを検出する

Question

VBAコードのヘルプが必要です。

私は名前が記載されたデータベースを持っています。それぞれの名前にはいくつかの間隔があります。値が「0」である最大の頂点から開始し、特定の深度（2000〜4000）で最大の底で終了する。

各区間は、番号（1~6）で分類されます。 私は一定の増分ステップで連続シリーズを作りたいと思っています。これは、間隔が小さなインクリメンタルステップで連続した系列に置き換えられることを意味します。連続シリーズの隣には、分類が記載されています。

結果は2番目のワークシート（ 'Samples'シート）に入れられます。 私は1つの名前のために必要な結果を得ることができました。今度はより多くの名前の結果を得たいと思いますが、新しい名前で新しいループを開始し、同じことをやり直す必要があることをコードに知らせる方法はわかりません（新しい最大の '0'の上端） 。

可能であれば、新しいブックに新しい名前のすべての結果が表示されます。

これは私がこの時点までに構築してきた私のコードです：

[コード]

Sub IntervalToSample() 

Dim Cancelled As Boolean, OldStatusbar As Boolean 
Dim NOI As Integer, TI As Integer, TS As Integer, DOF As Integer 
Dim i As Integer, j As Integer, Samples As Integer, SII As Integer 
Dim Counter As Long, Bounter As Long 
Dim Top As Double, Base As Double, Inc As Double, TopI As Double, BaseI As Double 
Dim WellN As String, Well_Name As String, Well_Top As String, Well_Base As String 
Dim Incremental_Step As String, Total_Intervals As String, Total_Samples As String 
Dim MainWkbk As Workbook, Well1 As Workbook 
Dim Start As Worksheet, Data As Worksheet, Sheet1 As Worksheet 

OldStatusbar = Application.DisplayStatusBar 

Set MainWkbk = ActiveWorkbook 

DOF = 5 
Counter = 0 
Bounter = 0 
SII = 0 
WellN = Sheets("Data").Cells(DOF + 1, 1) 
Top = Sheets("Data").Cells(DOF + 1, 2) 
Inc = Sheets("Start").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 

Incremental_Step = Sheets("Start").Cells(1, 5) 
Well_Name = Sheets("Start").Cells(2, 5) 
Well_Top = Sheets("Start").Cells(3, 5) 
Well_Base = Sheets("Start").Cells(4, 5) 
Total_Intervals = Sheets("Start").Cells(5, 5) 
Total_Samples = Sheets("Start").Cells(6, 5) 

Workbooks.Add 
ActiveWorkbook.SaveAs "H:\.......\.......\VBA\Code Set-up\VBA-DATABASE\Well1.xls" 
Set Well1 = ActiveWorkbook 

ActiveWorkbook.Sheets("Sheet1").Cells(1, 5) = Well_Name 
ActiveWorkbook.Sheets("Sheet1").Cells(2, 5) = Well_Top 
ActiveWorkbook.Sheets("Sheet1").Cells(3, 5) = Well_Base 
ActiveWorkbook.Sheets("Sheet1").Cells(4, 5) = Total_Intervals 
ActiveWorkbook.Sheets("Sheet1").Cells(5, 5) = Incremental_Step 
ActiveWorkbook.Sheets("Sheet1").Cells(6, 5) = Total_Samples 

ActiveWorkbook.Sheets("Sheet1").Cells(1, 6) = WellN 
ActiveWorkbook.Sheets("Sheet1").Cells(2, 6) = Top 
ActiveWorkbook.Sheets("Sheet1").Cells(3, 6) = Base 
ActiveWorkbook.Sheets("Sheet1").Cells(4, 6) = TI 
ActiveWorkbook.Sheets("Sheet1").Cells(5, 6) = Inc 
ActiveWorkbook.Sheets("Sheet1").Cells(6, 6) = TS 

Application.ScreenUpdating = False 
Application.StatusBar = True 

If Not Cancelled Then 
    MainWkbk.Activate 
    For i = 1 To TI 
    MainWkbk.Activate 
    TopI = Sheets("Data").Cells(i + DOF, 2) 
    BaseI = Sheets("Data").Cells(i + DOF, 3) 
    Samples = CInt((BaseI - TopI)/Inc) 
    Well1.Activate 
    Sheets("Sheet1").Cells(i, 12) = Samples 
    Application.StatusBar = i 
    Next i 

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

    For i = 1 To TI 
    SII = Sheets("Sheet1").Cells(i, 12) 
    If i = TI Then SII = SII + 1 
    For j = 1 To SII 
     Counter = Counter + 1 
     Well1.Sheets("Sheet1").Cells(Counter, 9) = MainWkbk.Sheets("Data").Cells(i + DOF, 13) 
     Bounter = Bounter + 1 
     Well1.Sheets("Sheet1").Cells(Bounter, 10) = MainWkbk.Sheets("Data").Cells(i + DOF, 34) 
    Next j 
    Next i 

End If          

Well1.Activate 
ActiveWorkbook.Close True 
MainWkbk.Activate 
Range("A1").Select 
ActiveWindow.ScrollRow = Range("A1").Row 

Application.ScreenUpdating = True 
Application.DisplayStatusBar = OldStatusbar 

End Subのここ

Sheet 'Data'

'Sheet1' in new workbook 'Well1'

Answer 1

が洗浄されますあなたのコードのアップバージョン：

Option Explicit 

Sub IntervalToSample() 

Dim Cancelled As Boolean, OldStatusbar As Boolean 
Dim NOI As Integer, TI As Integer, TS As Integer, DOF As Integer 
Dim i As Integer, j As Integer, Samples As Integer, SII As Integer 
Dim Counter As Long, Bounter As Long, LastRow As Long 
Dim Top As Double, Base As Double, Inc As Double, TopI As Double, BaseI As Double 
Dim WellN As String, Well_Name As String, Well_Top As String, Well_Base As String 
Dim Incremental_Step As String, Total_Intervals As String, Total_Samples As String 
Dim wbMain As Workbook, wbWell1 As Workbook 
Dim wsStart As Worksheet, wsData As Worksheet, wsSheet1 As Worksheet 

OldStatusbar = Application.DisplayStatusBar 

Set wbMain = ActiveWorkbook 
Set wsStart = wb.Sheets("Start") 
Set wsData = wb.Sheets("Data") 

DOF = 5 
Counter = 0 
Bounter = 0 
SII = 0 
WellN = wsData.Cells(DOF + 1, 1) 
Top = wsData.Cells(DOF + 1, 2) 
Inc = wsStart.Cells(1, 6) 
LastRow = wsData.Columns(1).End(xlDown).Row 
TI = LastRow - DOF 
Base = wsData.Cells(LastRow, 3) 
TS = Int((Base - Top)/Inc) + 2 

With wsStart 
    Incremental_Step = .Cells(1, 5) 
    Well_Name = .Cells(2, 5) 
    Well_Top = .Cells(3, 5) 
    Well_Base = .Cells(4, 5) 
    Total_Intervals = .Cells(5, 5) 
    Total_Samples = .Cells(6, 5) 
End With 

Set wbWell1 = Workbooks.Add 
wbWell1.SaveAs "H:\.......\.......\VBA\Code Set-up\VBA-DATABASE\Well1.xls" 

Set wsSheet1 = wbWell1.Sheets("Sheet1") 
With wsSheet1 
    .Cells(1, 5) = Well_Name 
    .Cells(2, 5) = Well_Top 
    .Cells(3, 5) = Well_Base 
    .Cells(4, 5) = Total_Intervals 
    .Cells(5, 5) = Incremental_Step 
    .Cells(6, 5) = Total_Samples 

    .Cells(1, 6) = WellN 
    .Cells(2, 6) = Top 
    .Cells(3, 6) = Base 
    .Cells(4, 6) = TI 
    .Cells(5, 6) = Inc 
    .Cells(6, 6) = TS 
End With 

Application.ScreenUpdating = False 
Application.StatusBar = True 

If Not Cancelled Then 
    For i = 1 To TI 
     TopI = wsData.Cells(i + DOF, 2) 
     BaseI = wsData.Cells(i + DOF, 3) 
     Samples = CInt((BaseI - TopI)/Inc) 
     wsSheet1.Cells(i, 12) = Samples 
     Application.StatusBar = i 
    Next i 

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

    For i = 1 To TI 
     SII = wsSheet1.Cells(i, 12) 
     If i = TI Then SII = SII + 1 
     For j = 1 To SII 
      Counter = Counter + 1 
      wsSheet1.Cells(Counter, 9) = wsData.Cells(i + DOF, 13) 
      Bounter = Bounter + 1 
      wsSheet1.Cells(Bounter, 10) = wsData.Cells(i + DOF, 34) 
     Next j 
    Next i 
End If 

wbWell1.Close True 

Application.ScreenUpdating = True 
Application.DisplayStatusBar = OldStatusbar 

End Sub 

上部にはOption Explicitが追加されています。これには、コードを実行する前にすべての変数を宣言する必要があります。あなたはこれの良い仕事をしましたが、それは常に含まれて良いです。

また、If Not Cancelled Thenの目的がわかりません。変数Cancelledをコードのどこにも使用しないので、常に同じになります。

コードに3つの異なるForループがあります。 1つにまとめることをお勧めします。そうすれば、何千もの行のデータを何度もループダウンする必要はありません。あなたは、名前の変更を考慮するために、以下のように追加することができます：あなたはその後、データは、新しい名前のために格納されている場所を変更するにはcurNameとNameCountを使用することができます

Dim curName As String 
Dim NameCount As Long 

'Add this just before your For loop 
curName = wsData.Cells(DOF + 1, 1).Value 
NameCount = 0 

'Add this just inside your For loop 
If wsData.Cells(i + DOF, 1) <> curName Then 
    curName = wsData.Cells(i + DOF, 1).Value 
    NameCount = NameCount + 1 
End If 

。