请老师帮助增加一点代码

xihaihandsp

将现有的代码加上 黄色区域的和值条件，vba代码怎么修改，向各位老师求助？ 查看代码密码是1

xihaihandsp

xihaihandsp

请大神帮助？万分感谢！！！！！！！！

ykcbf1100

你是用来赚钱的，这个适合付费做。

呵呵，VBA中还加了密码。

gwjkkkkk

没看懂，建议楼主模拟一下结果，并解除密码。。。

xihaihandsp

gwjkkkkk 发表于 2024-2-19 19:14
没看懂，建议楼主模拟一下结果，并解除密码。。。

vba密码是1

xihaihandsp

xihaihandsp

gwjkkkkk 发表于 2024-2-19 19:14
没看懂，建议楼主模拟一下结果，并解除密码。。。

Sub ZZHM()
    TextBox1.Text = ""
    TextBox1.Locked = False
    Application.ScreenUpdating = False
    HM = ""
    W = 0
    Z = 0
    N = Application.Count(Range("M1:O8"))
    If N = 0 Or (N Mod 3 > 0) Then MsgBox ("请设置定位条件！"): TextBox1.Text = "": End
    N = Application.Count(Range("M1:M8"))
    For i = 1 To N
        If (Application.Count(Range("M" & i & ":O" & i)) <> 3) Or (InStr(Cells(i, 16), "-") = 0) Then MsgBox ("条件 " & i & " 设置有误！"): End ' Range("M" & i & ":P" & i) = ""
    Next i
    B1 = Cells(1, 13): S1 = Cells(1, 14): G1 = Cells(1, 15): X1 = Val(Left(Cells(1, 16), 1)): D1 = Val(Right(Cells(1, 16), 1))
    B2 = Cells(2, 13): S2 = Cells(2, 14): G2 = Cells(2, 15): X2 = Val(Left(Cells(2, 16), 1)): D2 = Val(Right(Cells(2, 16), 1))
    B3 = Cells(3, 13): S3 = Cells(3, 14): G3 = Cells(3, 15): X3 = Val(Left(Cells(3, 16), 1)): D3 = Val(Right(Cells(3, 16), 1))
    B4 = Cells(4, 13): S4 = Cells(4, 14): G4 = Cells(4, 15): X4 = Val(Left(Cells(4, 16), 1)): D4 = Val(Right(Cells(4, 16), 1))
    B5 = Cells(5, 13): S5 = Cells(5, 14): G5 = Cells(5, 15): X5 = Val(Left(Cells(5, 16), 1)): D5 = Val(Right(Cells(5, 16), 1))
    B6 = Cells(6, 13): S6 = Cells(6, 14): G6 = Cells(6, 15): X6 = Val(Left(Cells(6, 16), 1)): D6 = Val(Right(Cells(6, 16), 1))
    B7 = Cells(7, 13): S7 = Cells(7, 14): G7 = Cells(7, 15): X7 = Val(Left(Cells(7, 16), 1)): D7 = Val(Right(Cells(7, 16), 1))
    B8 = Cells(8, 13): S8 = Cells(8, 14): G8 = Cells(8, 15): X8 = Val(Left(Cells(8, 16), 1)): D8 = Val(Right(Cells(8, 16), 1))
    ZX = Val(Left(Cells(2, 17), 1)): ZD = Val(Right(Cells(2, 17), 1))
    For i = 0 To 9
        For j = 0 To 9
            For k = 0 To 9
                C1 = IIf(InStr(B1, i) > 0, 1, 0) + IIf(InStr(S1, j) > 0, 1, 0) + IIf(InStr(G1, k) > 0, 1, 0)
                C2 = IIf(InStr(B2, i) > 0, 1, 0) + IIf(InStr(S2, j) > 0, 1, 0) + IIf(InStr(G2, k) > 0, 1, 0)
                C3 = IIf(InStr(B3, i) > 0, 1, 0) + IIf(InStr(S3, j) > 0, 1, 0) + IIf(InStr(G3, k) > 0, 1, 0)
                C4 = IIf(InStr(B4, i) > 0, 1, 0) + IIf(InStr(S4, j) > 0, 1, 0) + IIf(InStr(G4, k) > 0, 1, 0)
                C5 = IIf(InStr(B5, i) > 0, 1, 0) + IIf(InStr(S5, j) > 0, 1, 0) + IIf(InStr(G5, k) > 0, 1, 0)
                C6 = IIf(InStr(B6, i) > 0, 1, 0) + IIf(InStr(S6, j) > 0, 1, 0) + IIf(InStr(G6, k) > 0, 1, 0)
                C7 = IIf(InStr(B7, i) > 0, 1, 0) + IIf(InStr(S7, j) > 0, 1, 0) + IIf(InStr(G7, k) > 0, 1, 0)
                C8 = IIf(InStr(B8, i) > 0, 1, 0) + IIf(InStr(S8, j) > 0, 1, 0) + IIf(InStr(G8, k) > 0, 1, 0)

                T1 = IIf(X1 <= C1 And C1 <= D1 And Cells(1, 13) >= 0, 1, 0)
                T2 = IIf(X2 <= C2 And C2 <= D2 And Cells(2, 13) >= 0, 1, 0)
                T3 = IIf(X3 <= C3 And C3 <= D3 And Cells(3, 13) >= 0, 1, 0)
                T4 = IIf(X4 <= C4 And C4 <= D4 And Cells(4, 13) >= 0, 1, 0)
                T5 = IIf(X5 <= C5 And C5 <= D5 And Cells(5, 13) >= 0, 1, 0)
                T6 = IIf(X6 <= C6 And C6 <= D6 And Cells(6, 13) >= 0, 1, 0)
                T7 = IIf(X7 <= C7 And C7 <= D7 And Cells(7, 13) >= 0, 1, 0)
                T8 = IIf(X8 <= C8 And C8 <= D8 And Cells(8, 13) >= 0, 1, 0)

                If T1 And T2 And T3 And T4 And T5 And T6 And T7 And T8 Then
                    HM = HM & i & j & k & " "
                    W = W + 1
                End If
            Next k
        Next j
    Next i

' 假设 HM 已经是一个包含空格分隔的三位数的字符串
  
' 初始化输出字符串
Dim FilteredNumbers As String
FilteredNumbers = ""
  
' 分割 HM 字符串，得到每个三位数
Dim Numbers() As String
Numbers = Split(HM, " ")
  
' 遍历每个三位数
Dim ii As Long
For ii = LBound(Numbers) To UBound(Numbers)
    ' 提取当前三位数
    Dim CurrentNumber As String
    CurrentNumber = Numbers(ii)
      
    ' 计算当前三位数的和值
    Dim SumOfNumber As Integer
    SumOfNumber = Val(Mid(CurrentNumber, 1, 1)) + Val(Mid(CurrentNumber, 2, 1)) + Val(Mid(CurrentNumber, 3, 1))
      
    ' 检查和值是否等于 Sheet1 中 R1:AB1 区域的任一和值
    Dim jj As Long
    Dim CellValue As Variant
    Dim FoundMatch As Boolean
    FoundMatch = False
      
    ' 获取 Sheet1 中 R1:AB1 区域的行数
   
      Dim LastRow As Long
LastRow = ThisWorkbook.Sheets("Sheet1").Cells(ThisWorkbook.Sheets("Sheet1").Rows.Count, 18).End(xlUp).Row
If LastRow = 0 Then LastRow = 1 ' 如果找不到数据，则设置为1，避免从0开始循环
    For jj = 1 To LastRow
        CellValue = ThisWorkbook.Sheets("Sheet1").Cells(jj, 18).Value ' 假设 R 列是第 18 列
        If Not IsEmpty(CellValue) And CellValue = SumOfNumber Then
            FoundMatch = True
            Exit For
        End If
    Next jj
      
    ' 如果找到匹配项，将三位数添加到输出字符串
    If FoundMatch Then
        If Len(FilteredNumbers) > 0 Then
            FilteredNumbers = FilteredNumbers & " "
        End If
        FilteredNumbers = FilteredNumbers & CurrentNumber
    End If
Next ii
  
' 将满足条件的三位数输出到 TextBox1.Text
TextBox1.Text = "满足条件的三位数：" & Trim(FilteredNumbers)
TextBox1.Locked = True
Application.ScreenUpdating = True
End Sub
这段代码后面的和值过滤 出现下标越界 ，能不能帮我看看，万分感谢！

xihaihandsp

ykcbf1100 发表于 2024-2-19 18:41
你是用来赚钱的，这个适合付费做。

呵呵，VBA中还加了密码。

已修改好代码
Sub FilterThreeDigitNumbers()
   
    Dim HM As String
    Application.ScreenUpdating = False
    HM = ""
    W = 0
    Z = 0
    N = Application.Count(Range("M1:O8"))
    If N = 0 Or (N Mod 3 > 0) Then MsgBox ("   请设置定位条件！"): TextBox1.Text = "": End
    N = Application.Count(Range("M1:M8"))
    For i = 1 To N
    If (Application.Count(Range("M" & i & ":O" & i)) <> 3) Or (InStr(Cells(i, 16), "-") = 0) Then MsgBox ("  条件 " & i & " 设置有误！"): End ' Range("M" & i & ":P" & i) = ""
    Next i
    B1 = Cells(1, 13): S1 = Cells(1, 14): G1 = Cells(1, 15): X1 = Val(Left(Cells(1, 16), 1)): D1 = Val(Right(Cells(1, 16), 1))
    B2 = Cells(2, 13): S2 = Cells(2, 14): G2 = Cells(2, 15): X2 = Val(Left(Cells(2, 16), 1)): D2 = Val(Right(Cells(2, 16), 1))
    B3 = Cells(3, 13): S3 = Cells(3, 14): G3 = Cells(3, 15): X3 = Val(Left(Cells(3, 16), 1)): D3 = Val(Right(Cells(3, 16), 1))
    B4 = Cells(4, 13): S4 = Cells(4, 14): G4 = Cells(4, 15): X4 = Val(Left(Cells(4, 16), 1)): D4 = Val(Right(Cells(4, 16), 1))
    B5 = Cells(5, 13): S5 = Cells(5, 14): G5 = Cells(5, 15): X5 = Val(Left(Cells(5, 16), 1)): D5 = Val(Right(Cells(5, 16), 1))
    B6 = Cells(6, 13): S6 = Cells(6, 14): G6 = Cells(6, 15): X6 = Val(Left(Cells(6, 16), 1)): D6 = Val(Right(Cells(6, 16), 1))
    B7 = Cells(7, 13): S7 = Cells(7, 14): G7 = Cells(7, 15): X7 = Val(Left(Cells(7, 16), 1)): D7 = Val(Right(Cells(7, 16), 1))
    B8 = Cells(8, 13): S8 = Cells(8, 14): G8 = Cells(8, 15): X8 = Val(Left(Cells(8, 16), 1)): D8 = Val(Right(Cells(8, 16), 1))
    ZX = Val(Left(Cells(2, 17), 1)): ZD = Val(Right(Cells(2, 17), 1))
        For i = 0 To 9
          For j = 0 To 9
            For k = 0 To 9
                 C1 = IIf(InStr(B1, i) > 0, 1, 0) + IIf(InStr(S1, j) > 0, 1, 0) + IIf(InStr(G1, k) > 0, 1, 0)
                 C2 = IIf(InStr(B2, i) > 0, 1, 0) + IIf(InStr(S2, j) > 0, 1, 0) + IIf(InStr(G2, k) > 0, 1, 0)
                 C3 = IIf(InStr(B3, i) > 0, 1, 0) + IIf(InStr(S3, j) > 0, 1, 0) + IIf(InStr(G3, k) > 0, 1, 0)
                 C4 = IIf(InStr(B4, i) > 0, 1, 0) + IIf(InStr(S4, j) > 0, 1, 0) + IIf(InStr(G4, k) > 0, 1, 0)
                 C5 = IIf(InStr(B5, i) > 0, 1, 0) + IIf(InStr(S5, j) > 0, 1, 0) + IIf(InStr(G5, k) > 0, 1, 0)
                 C6 = IIf(InStr(B6, i) > 0, 1, 0) + IIf(InStr(S6, j) > 0, 1, 0) + IIf(InStr(G6, k) > 0, 1, 0)
                 C7 = IIf(InStr(B7, i) > 0, 1, 0) + IIf(InStr(S7, j) > 0, 1, 0) + IIf(InStr(G7, k) > 0, 1, 0)
                 C8 = IIf(InStr(B8, i) > 0, 1, 0) + IIf(InStr(S8, j) > 0, 1, 0) + IIf(InStr(G8, k) > 0, 1, 0)
                 
                 T1 = IIf(X1 <= C1 And C1 <= D1 And Cells(1, 13) >= 0, 1, 0)
                 T2 = IIf(X2 <= C2 And C2 <= D2 And Cells(2, 13) >= 0, 1, 0)
                 T3 = IIf(X3 <= C3 And C3 <= D3 And Cells(3, 13) >= 0, 1, 0)
                 T4 = IIf(X4 <= C4 And C4 <= D4 And Cells(4, 13) >= 0, 1, 0)
                 T5 = IIf(X5 <= C5 And C5 <= D5 And Cells(5, 13) >= 0, 1, 0)
                 T6 = IIf(X6 <= C6 And C6 <= D6 And Cells(6, 13) >= 0, 1, 0)
                 T7 = IIf(X7 <= C7 And C7 <= D7 And Cells(7, 13) >= 0, 1, 0)
                 T8 = IIf(X8 <= C8 And C8 <= D8 And Cells(8, 13) >= 0, 1, 0)
               
                 If T1 And T2 And T3 And T4 And T5 And T6 And T7 And T8 Then HM = HM & i & j & k & " ": W = W + 1
            Next k
          Next j
        Next
         
    ' 过滤和值等于 Sheet1 中区域 R1:AB1 的三位数
        Dim FilteredNumbers As String
        Dim Number As String
        Dim Sum As Integer
        Dim r As Range
        Dim FoundMatch As Boolean
        Dim ii As Integer
        Dim jj As Integer
        Dim Count As Integer ' 新增变量，用于计算满足条件的三位数的数量
         
        ' 初始化输出字符串和计数器
        FilteredNumbers = ""
        Count = 0
         
        ' 遍历 HM 中的每个三位数
        For ii = 1 To Len(HM) - 2 Step 4 ' 因为每个数后面都有一个空格，所以步长为4
            Number = Mid(HM, ii, 3) ' 提取三位数
              
            ' 计算三位数的和值
            Sum = 0
            For jj = 1 To Len(Number)
                Sum = Sum + CInt(Mid(Number, jj, 1))
            Next jj
              
            ' 检查和值是否出现在 Sheet1 的 R1:AB1 区域
            FoundMatch = False
            For Each r In ThisWorkbook.Sheets("Sheet1").Range("R1:AB1")
                If r.Value = Sum Then
                    FoundMatch = True
                    Exit For
                End If
            Next r
              
            ' 如果找到匹配项，则添加到输出字符串并增加计数器
            If FoundMatch Then
                Count = Count + 1 ' 增加计数器
                If Len(FilteredNumbers) > 0 Then
                    FilteredNumbers = FilteredNumbers & " "
                End If
                FilteredNumbers = FilteredNumbers & Number
            End If
        Next ii
         
        ' 显示结果
        TextBox1.Text = "满足条件的三位数：" & Trim(FilteredNumbers) & vbCrLf & "总数：" & Count
        TextBox1.Locked = True
        Application.ScreenUpdating = True
End Sub