抓取范围的架构

Question

我的代码主要工作，但它需要一段时间的调试，所以我开始认为我的架构可能有缺陷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内置块。因此，这是我用来放下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 

我已经调试过几个错误。目前的情况是，depreRng正在打破，因为我的数学不好。我绊倒了它，而不是调试每个错误，我该如何构建这个更好的？

Answer 1

好吧，我的方法是不同的。首先，我使用一个过滤器来查找具有您正在查找的索引的行的范围，然后在此过滤的行内循环以查找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 

这就是我怎么会想象你的工作的宏;）

编辑1：
我忘了，这将留下一张含有...使用activesheet.showalldata过滤器为显示所有的行，不仅过滤那些

编辑2：
测试

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（我假设他们永远不会是字母）。如果是这种情况，那么你可以创建一个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 

让我知道你的想法。