build筑抢占范围

我的代码主要工作，但它需要一段时间的debugging，所以我开始认为我的架构可能有缺陷XD 那么我怎么能架构这更好？

我有一组空白行分隔的数据。 除了空白行之外，还可以通过列C中的ID区分每个组。 对于每个ID，我需要捕获B列中的各种数字。 有时这些数字只能从5开始，有时却从7开始。 我需要分别捕获5和7。

 With projWS With .Range("C1:C6000") Set f = .Find(cc, LookIn:=xlValues, lookat:=xlPart) End With If Not f Is Nothing Then 'first occurence found counter = 0 i = f.Row Do acct = .Cells(i, 2) If (Len(projWS.Cells(i, 3)) < 1 Or Left(acct, 1) = "7") And done = False Then acctStart = f.Row acctRows = i - acctStart Set acctRng = .Range(.Cells(acctStart, 2), .Cells(i - 1, 5)) Set amountRng = .Range(.Cells(acctStart, 7), .Cells(i - 1, 8)) done = True 'set flag to show range has been filled End If counter = counter + 1 'increment counter i = i + 1 'move to next row Loop Until Len(.Cells(i, 3)) < 1 'keep looping until blank row End If If counter - 1 > acctRows Then 'how we determine if there's a "7" flag = True 'so we set flag to true Set depreRng = Range(.Cells(acctStart + acctRows, 2), .Cells(i - 1, 8)) dep = depreRng.Value2 'store range into array End If End With 

---

捕获后，我需要把它放到另一个工作表中。 这个工作表已经有一个内置的块。因此，这是我用来放下7的范围的循环。 没有内置的5块。

  For r = 112 To 120 For k = 1 To UBound(dep()) If .Cells(r, 1).Value2 = Trim(dep(k, 1)) Then Debug.Print .Cells(r, 1).Value2 .Cells(r, 6) = dep(k, 6) .Cells(r, 7) = dep(k, 7) Exit For Else .Cells(r, 6) = 0 .Cells(r, 7) = 0 End If Next k Next r 

我已经debugging了几个错误。 目前的情况是，因为我的math不好， depreRng正在打破。 我绊倒了每一个错误，而不是debugging每个错误，我怎么能更好地devise这个 ？

Answer 1

好的，我的方法是不同的。 首先，我使用一个filter来find你正在寻找的索引的行的范围，然后在这个过滤的行内循环查找5xx和7xx范围。 代码：

 Sub Macro1() Dim rng_5xx_start, rng_5xx_stop, rng_7xx_start, rng_7xx_stop As Integer rng_5xx_start = 0 rng_5xx_stop = 0 rng_7xx_start = 0 rng_7xx_stop = 0 Dim range_5xx, range_7xx As String 'filter for the index you are looking for 'specify the maximum range, the field is the "offset" from the column B (the firts of the range), so for filter for column C you need to put 2, criteria...is the critera :) ActiveSheet.Range("$B$1:$H$6000").AutoFilter Field:=2, Criteria1:="b" 'the filter returns only the rows with the specifyed index, now a for inside this rows for find the 5xx and the 7xx sub-ranges For Each Row In ActiveSheet.Range("b1:b6000").SpecialCells(xlCellTypeVisible) If Cells(Row.Row, 2).Value > 4999 And Cells(Row.Row, 2).Value < 6000 Then 'or any test for understnd if i'm in the 5xx range, if you prefer use the strings use something like left(cells(row.row,2).value,1) = "5" If rng_5xx_start = 0 Then 'found the first row with a 5xx value rng_5xx_start = Row.Row 'set the start of the range to this row End If If rng_5xx_stop < Row.Row Then 'the row where i am is in the 5xx range and is grater than the current end i noticed rng_5xx_stop = Row.Row 'refresh the end of the range...at the end this will have the last number of row of the 5xx range End If End If If Cells(Row.Row, 2).Value > 6999 And Cells(Row.Row, 2).Value < 8000 Then 'same as above but for 7xx range If rng_7xx_start = 0 Then rng_7xx_start = Row.Row End If If rng_7xx_stop < Row.Row Then rng_7xx_stop = Row.Row End If End If Next If rng_5xx_start = 0 Then 'not found 5xx rows range_5xx = "" 'or False, or what you prefer... Else range_5xx = "B" & rng_5xx_start & ":H" & rng_5xx_stop End If If rng_7xx_start = 0 Then 'not found 7xx rows range_7xx = "" 'or False, or what you prefer... Else range_7xx = "B" & rng_7xx_start & ":H" & rng_7xx_stop End If End Sub 

这就是我想像一个macros的工作;）

编辑1：
我忘了这将离开工作表的filter…使用activesheet.showalldata显示所有的行，而不仅仅是过滤的

编辑2：
testing

  If rng_5xx_stop < Row.Row Then rng_5xx_stop = Row.Row End If 

和

  If rng_7xx_stop < Row.Row Then rng_7xx_stop = Row.Row End If 

是没有必要的，这是足够的做rng_5xx_stop = Row.Row和rng_7xx_stop = Row.Row并保存两个IF语句

Answer 2

您正在根据B列中单元格值的第一个数字来对单元格进行分组（我假设它们不能是字母）。 如果是这种情况，那么你可以创build一个0到9的数组，并将你的范围存储在那里。 然后通过range.areas为了得到你正在寻找的分组（如在屏幕截图中突出显示）。

要做到这一点，就需要这样的东西。 我评论了代码，试图更多地解释它：

 Sub tgr() Dim wsData As Worksheet Dim rColB As Range Dim BCell As Range Dim aRanges(0 To 9) As Range Dim SubGroup As Range Dim lRangeNum As Long Dim i As Long 'Change to your actual worksheet Set wsData = ActiveWorkbook.ActiveSheet 'Change to your actual column range, this is based off the sample data Set rColB = wsData.Range("B1", wsData.Cells(wsData.Rows.Count, "B").End(xlUp)) 'Loop through the column range For Each BCell In rColB.Cells 'Make sure the cell is populated and the starting character is numeric If Len(BCell.Value) > 0 And IsNumeric(Left(BCell.Value, 1)) Then 'Get the starting digit lRangeNum = Val(Left(BCell.Value, 1)) 'Check if any ranges have been assigned to that array index location 'If not, start a range at that array index 'If so, combine the ranges with Union Select Case (aRanges(lRangeNum) Is Nothing) Case True: Set aRanges(lRangeNum) = BCell Case Else: Set aRanges(lRangeNum) = Union(aRanges(lRangeNum), BCell) End Select End If Next BCell 'You can use any method you want to access the ranges, this just loops 'through the array indices and displays the range areas of each For i = 0 To 9 If Not aRanges(i) Is Nothing Then For Each SubGroup In aRanges(i).Areas 'Do what you want with it here 'This just selects the subgroup so you can see it found the groups properly SubGroup.Select MsgBox SubGroup.Address Next SubGroup End If Next i End Sub 

Answer 3

我看到你已经完全重写了你的代码，但是我想提供一下我将如何做，并想知道你的想法。 这会是低效吗？ 我猜这可能是因为你必须每次增加4次读取单元格中的第一个字符，但是如果这是一个大问题，不能确定。

 Dim start_row As Long Dim end_row As Long start_row = 1 end_row = 0 For i = 2 To Range("B" & Rows.Count).End(xlUp).Row If Cells(i - 1, 2) = "" Then start_row = i ElseIf Left(Cells(i - 1, 2), 1) <> Left(Cells(i, 2), 1) Then start_row = i End If If Cells(i + 1, 2) = "" Then end_row = i ElseIf Left(Cells(i + 1, 2), 1) <> Left(Cells(i, 2), 1) Then end_row = i End If If end_row <> 0 Then Call copy_range(start_row, end_row) end_row = 0 End If Next i 

另一种让你只读一次的方法就可以

 Dim start_row As Long Dim end_row As Long Dim char_above As String Dim this_char As String start_row = 1 end_row = 1 For i = 1 To Range("B" & Rows.Count).End(xlUp).Row If Cells(i, 2) = "" Then end_row = i - 1 if i <>1 then Call copy_range(start_row, end_row,char_above) start_row = i + 1 Else this_char = Left(Cells(i, 2), 1) If this_char <> char_above Then end_row = i - 1 if i<> 1 then Call copy_range(start_row, end_row,char_above) start_row = i End If char_above = this_char End If Next i 

让我知道你的想法。