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次，但如果这是一个大问题则不是shure。

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

让我知道你的想法。

抓住范围的建筑

3 个答案: