간격이 0에서 다시 시작될 때 새 루프 감지

Question

VBA 코드와 관련하여 도움이 필요합니다.

나는 이름이 나열된 데이터베이스가 있습니다. 각 이름에는 여러 개의 간격이 있습니다! 값이 '0'인 최대 상단에서 시작하여 특정 깊이 (2000-4000)에서 최대 기준으로 끝납니다.

각 간격은 숫자 (1 - 6)로 분류됩니다. 나는 일정한 증분 단계로 연속적인 시리즈를 만들고 싶다. 이것은 간격이 작은 증분 단계가있는 연속 시리즈로 대체됨을 의미합니다. 연속 시리즈 옆에는 분류가 표시됩니다.

결과는 두 번째 워크 시트 ('샘플'시트)에 저장됩니다. 나는 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 

최종 하위 여기

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을 사용하지 않으므로 항상 동일합니다.

코드에는 세 가지 다른 For 루프가 있습니다. 수있는 경우 수천 줄의 데이터 줄을 여러 번 반복 할 필요가 없으면이를 하나로 결합하는 것이 좋습니다. 그런 다음 이름 변경을 고려하여 다음을 추가 할 수 있습니다 : 당신은 다음 데이터를 새 이름으로 저장되는 위치 변경 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 

.