抓取範圍的架構

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 

讓我知道你的想法。