Question

上下文：
Untitled.tiff
我希望程序能够查看专栏B，找出第一个＆＃34; < / >＆＃34; （这是纯粹的风格，可以在必要时更改 - 它只用于分解数据）作为单元格B9和下一个＆＃34; < / >的一周开始＆＃34; （{1}}在本周结束时。所以我感兴趣的范围是B16。然后，它会将这些数字从B10-B15加到J10（获奖列）并将该总和粘贴到J15（周总计列）中。然后可以使用＆＃39; Hours＆＃39;和＆＃39;周时间＆＃39;在接下来的一周（以及之后），本周结束时间为＆＃39; ＆＃34; L16＆＃34;成为本周的开始，程序一直持续到< / >。

我没有任何VBA经验，所以做了以下不完整的尝试（基于我在网上找到的），但感觉太过于深入，不求助。

B200

感谢您的帮助，如果我能更清楚或详细说明，请告诉我。

Answer 1

以下代码将遍历200行，查找您的符号。找到后，它将对J列中的数字求和当前行和最后一个符号之间的行。

我已经包含了两行来更新公式。对我来说，第二个更容易理解。

Sub Work()
    Dim row As Integer
    row = 4
    Dim topRowToAdd As Integer 'Remember which row is the 
                               'top of the next sum
    topRowToAdd = 4

    While row <= 200
        If Cells(row, 2) = "</>" Then
            'Cells(row, 10).FormulaR1C1 = "=SUM(R[" & -(row - topRowToAdd) & "]C[0]:R[" & -1 & "]C[0])"
            Cells(row, 10).Value = "=SUM(J" & topRowToAdd & ":J" & row - 1 & ")"
            topRowToAdd = row + 1
        End If
        row = row + 1
    Wend
End Sub

Answer 2

Sub Work()
    Dim rng As Range, rngFound As Range

    Set rng = Range("B:B")

    Set rngFound = rng.Find("</>")

    If rngFound.Value2 = "</>" Then
        'whatever you want to do    
    End If

End Sub

所以第二眼就看起来像这样。如果您想使其结构化，则需要先使用 countifs 功能。

Sub Work()
    Dim rng As Range, rngFound(1) As Range

    Set rng = Range("B1:B200")
On Error GoTo Err 'it is quite possible it will run into an error if there are no matches and I'm too lazy for structured solution
    Set rngFound(0) = rng.Find(What:="</>", LookAt:=xlWhole, SearchDirection:=xlNext) 'finds the first
    Set rngFound(1) = rng.Find(What:="</>", LookAt:=xlWhole, SearchDirection:=xlNext, After:=rngFound(0)) 'finds the first after the first (i.e. the second)
    Set rngFound(0) = rngFound(0).Offset(1, 8) '8 is the difference between B and J, row shifts as per description, I advise you to make it a variable
    Set rngFound(1) = rngFound(1).Offset(-1, 8)
    If rngFound(1).Row > rngFound(0).Row Then 'if it's not higher, then it recurred and found the first range again
            rngFound(1).Offset(1, 2).Formula = "=SUM(" & Range(rngFound(0), rngFound(1)).Address & ")" 'L column will have the sum as a formula
        Else
            MsgBox "There is a single match in " & rng.Address(False, False)
    End If

If False Then
Err:
    MsgBox "There are no matches in " & rng.Address(False, False)
End If
End Sub

现在为大结局：

Sub Work()
    Dim rng As Range, rngFound() As Range, rngdiff(1) As Long, rngcount As Long

    Set rng = Range("B1:B200")
    rngcount = rng.Cells.Count
    ReDim rngFound(rngcount)
    rngdiff(0) = Range("J1").Column - rng.Column ' the range that needs to be summed is in column J
    rngdiff(1) = Range("L1").Column - rng.Column ' the range containing the formula is in column L

On Error GoTo Err 'it is quite possible it will run into an error if there are no matches and I'm too lazy for structured solution
    Set rngFound(0) = rng.Find(What:="</>", LookAt:=xlWhole, SearchDirection:=xlNext) 'finds the first
    'loop starts
    For i = 1 To rngcount
        Set rngFound(i) = rng.Find(What:="</>", LookAt:=xlWhole, SearchDirection:=xlNext, After:=rngFound(i - 1)) 'finds the next
        If rngFound(i).Row > rngFound(i - 1).Row Then 'if it's not higher, then it recurred and found the first range again
                rngFound(i).Offset(0, rngdiff(1)).Formula = "=SUM(" & Range(rngFound(i - 1).Offset(1, rngdiff(0)), rngFound(i).Offset(-1, rngdiff(0))).Address & ")" 'L column will have the sum as a formula
            Else
                Exit Sub 'if it recurred the deed is done
        End If
    Next i

If False Then
Err:
    MsgBox "There are no matches in " & rng.Address(False, False)
End If
End Sub

一列的Excel VBA宏，如果为true，则将公式应用于另一列

2 个答案: