[已解决]VBA 代码增加一个功能，求高手帮忙下

zames

VBA代码里增加代码，要求表格 AM 列可以自动递增 1 后再自动累加单元格 AT28 ,难度是在累加或者递增时，单元格 AM 的第 1 2 3 位数遇到 1 4 7 时自动递增为非 1 4 7 数值，自己试了很久搞不定，求老师们帮忙，谢谢！

最佳答案

月排行榜 / 总排行榜

cutecpu

2023-1-15 15:51

zames 发表于 2023-2-2 14:28
您好！

附件以传，附截图。

已修正

跳转到最佳答案楼层

cutecpu

zames 发表于 2023-2-2 14:28
您好！

附件以传，附截图。

已修正

砂海

单纯解决 147的话
Sub X147()
    Dim a
    a = CInt(InputBox("输入a", "", 1147))
    Debug.Print "a = ", a
   
    For i = 1 To 3
        k = CInt(Mid(a, 5 - i, 1))
        Select Case k
        Case 1, 4, 7
            a = a + 10 ^ (i - 1)
        End Select
    Next i
   
    Debug.Print a
End Sub

zames

老师们都忙着过年了

cutecpu

1. Sub demo()
   
2.    a = [av3:ax22]
   
3.    ReDim b(1 To Application.Sum([ax3:ax22]))
   
4.    v = [at28]
   
5.    For i = 1 To UBound(a)
   
6.       If a(i, 1) = 0 Then GoTo 1
   
7.       n = a(i, 1)
   
8.       For k = 1 To a(i, 3)
   
9.          c = c + 1: b(c) = n
   
10.          n = Format(IIf(k Mod 2, n + 1, n + v), "0000")
    
11.          n = Replace(Replace(Replace(Left(n, 3), "1", "2"), "4", "5"), "7", "8") & Right(n, 1)
    
12.       Next
    
13. 1   Next
    
14.     [am3:am5000].ClearContents
    
15.     [am3].Resize(UBound(b)) = Application.Transpose(b)
    
16. End Sub
    

复制代码

祝順心，南無阿彌陀佛！

zames

cutecpu 发表于 2023-1-17 16:03
祝順心，南無阿彌陀佛！

新年快乐！

当单元格 AY 数值为空时，点控件按钮 计算 会出现运行错误 “9”，能不能把控件 计算 按钮一并并入 copy 这个控件，即点击 copy 控件就可以一起计算完成任务。再则若单元格 AY 为空白时，点控件按钮则清理那些要生成的数据。

再次感谢您.

zames

zames 发表于 2023-1-21 13:24
新年快乐！

当单元格 AY 数值为空时，点控件按钮 计算 会出现运行错误 “9”，能不能把控件 计算 按钮 ...

老师，新年快乐！

不着急，等节后帮忙看看就可以。


祝您新春快乐，万事如意！

zames

cutecpu 发表于 2023-1-17 16:03
祝順心，南無阿彌陀佛！

您好！


我是新手，没有上传图片的权限，截图上传就出现这个提示 “抱歉，您的帖子超过 50000 个字符的限制"，所以您有电脑可以上网后帮忙抽空看看我上面上传的压缩包。

谢谢！

祝新春快乐！

cutecpu

zames 发表于 2023-1-30 13:34
您好！

已修改

zames

cutecpu 发表于 2023-1-31 11:07
已修改

您好！

原先的那些代码没有保留呀，原先那些功能还需要的。

--------------------------------------------------
Private Sub CommandButton1_Click()
  Dim jrr(1 To 60000, 1 To 8)
  Dim krr(1 To 60000, 1 To 1)
  Dim trr(1 To 47)
  Application.ScreenUpdating = False
  Application.Calculation = xlCalculationManual
   s = "#BCDFGHJKLMNPQRSTVWXYZ"
   Set dic = CreateObject("Scripting.dictionary")
   Set dicN = CreateObject("Scripting.dictionary")
   Set dicS = CreateObject("Scripting.dictionary")
    Set dicC = CreateObject("Scripting.dictionary")

    For i = 3 To Cells(Rows.Count, 47).End(xlUp).Row
        If Cells(i, "AX") <> "" Then
            n = Cells(i, "AX")
             For j = 1 To n
               num = num + 1
                 For c = 1 To 8
                    jrr(num, c) = Cells(i, 39 + c)
                 Next
rerandom:
        dic.RemoveAll
        dicN.RemoveAll
        dicS.RemoveAll
          Do
            Randomize
             k = Int(Rnd * 9)
             dic(k) = ""
          Loop Until dic.Count = 4

           Do
             Randomize
              k = Int(Rnd * 47) + 1
             dicN(k) = ""
           Loop Until dicN.Count = 47

            Do
              Randomize
             k = Int(Rnd * 22) + 1
             dicS(Mid(s, k, 1)) = ""
           Loop Until dicS.Count = 11

            T = Join(dic.keys(), "") & Join(dicS.keys(), "")
            If dicC.Exists(T) Then GoTo rerandom
            dicC(T) = ""
            dn = dicN.keys
            For k = 0 To UBound(dn)
               krr(num, 1) = Mid(T, dn(k), 1) & krr(num, 1)
             Next
          dicN.RemoveAll
          dicS.RemoveAll
          dic.RemoveAll

            Next
        End If

    Next

    [A3].Resize(60000, 8).ClearContents
    [i3].Resize(60000, 1).ClearContents
    If num > 0 Then
      [A3].Resize(num, 8) = jrr
      [i3].Resize(num, 1) = krr
    End If
      Application.ScreenUpdating = True
      Application.Calculation = xlCalculationAutomatic

      Dim x As Integer, mrr, h As Integer, Nrr(), z As Integer
      h = Cells(Rows.Count, "I").End(xlUp).Row
      If h = 1 Then Exit Sub
      mrr = Range("I3:I" & h)
      For x = 1 To UBound(mrr, 1)
            z = z + 1
            ReDim Preserve Nrr(1 To z)
            Nrr(z) = Range("BC25").Value & mrr(x, 1)
      Next x
        Range("I3").Resize(z) = Application.Transpose(Nrr)
End Sub
Sub 取消超链接()
   Dim a As Integer, i As Integer
   a = Cells(Rows.Count, "I").End(xlUp).Row
   For i = 3 To a
        If Range("i" & i).Hyperlinks.Count > 0 Then
            Range("i" & i).Hyperlinks.Delete
        End If
   Next i
End Sub

Private Sub CommandButton2_Click()
取消超链接
End Sub
-------------------------------------------------------------------------