当间隔从0再次开始时检测新循环

时间：2016-06-22 15:14:23

标签： excel vba excel-vba

我需要有关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

End Sub

Sheet 'Data'

'Sheet1' in new workbook 'Well1'

1 个答案:

答案 0 :(得分：0)

以下是代码的清理版本：

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循环。如果可以，我建议将它们合并为一个，这样您就不需要多次循环遍历数千行数据。然后，您可以添加以下内容以说明名称更改：

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

然后，您可以使用curName和NameCount更改新名称的数据存储位置。

相关问题
最新问题