Excel精英培训网

 找回密码
 注册

QQ登录

只需一步,快速开始

数据透视表40+个常用小技巧,让你一次学会!
查看: 347|回复: 21

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

[复制链接]
发表于 2023-1-15 15:51 | 显示全部楼层 |阅读模式
2学分
VBA代码里增加代码,要求表格 AM 列可以自动递增 1 后再自动累加单元格 AT28 ,难度是在累加或者递增时,单元格 AM 的第 1 2 3 位数遇到 1 4 7 时自动递增为非 1 4 7 数值,自己试了很久搞不定,求老师们帮忙,谢谢!
最佳答案
2023-1-15 15:51
zames 发表于 2023-2-2 14:28
您好!

附件以传,附截图。

已修正

Office File.zip

451.12 KB, 下载次数: 5

最佳答案

发表于 2023-1-15 15:51 | 显示全部楼层    本楼为最佳答案   
zames 发表于 2023-2-2 14:28
您好!

附件以传,附截图。

已修正

demo5.zip

258.33 KB, 下载次数: 3

回复

使用道具 举报

发表于 2023-1-15 16:51 | 显示全部楼层
单纯解决 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
回复

使用道具 举报

 楼主| 发表于 2023-1-16 12:59 | 显示全部楼层
老师们都忙着过年了
回复

使用道具 举报

发表于 2023-1-17 16:03 | 显示全部楼层
本帖最后由 cutecpu 于 2023-1-17 17:23 编辑
  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
复制代码
祝順心,南無阿彌陀佛!
log.png

demo.zip

261.42 KB, 下载次数: 6

回复

使用道具 举报

 楼主| 发表于 2023-1-21 13:24 | 显示全部楼层
cutecpu 发表于 2023-1-17 16:03
祝順心,南無阿彌陀佛!

新年快乐!

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

再次感谢您.

demo-1.zip

310.1 KB, 下载次数: 6

点评

哈哈,目前沒有電腦,可以截個圖,讓我看一下AY為空是什麼狀況嗎  发表于 2023-1-21 20:50
回复

使用道具 举报

 楼主| 发表于 2023-1-22 14:46 | 显示全部楼层
zames 发表于 2023-1-21 13:24
新年快乐!

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

老师,新年快乐!

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


祝您新春快乐,万事如意!

点评

好喔~新年快樂。阿彌陀佛!  发表于 2023-1-22 14:50
回复

使用道具 举报

 楼主| 发表于 2023-1-30 13:34 | 显示全部楼层
cutecpu 发表于 2023-1-17 16:03
祝順心,南無阿彌陀佛!

您好!


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

谢谢!

祝新春快乐!



点评

好喔~有電腦上網幫您看喔  发表于 2023-1-30 18:51
回复

使用道具 举报

发表于 2023-1-31 11:07 | 显示全部楼层

已修改

demo2.zip

253.94 KB, 下载次数: 7

回复

使用道具 举报

 楼主| 发表于 2023-2-1 14:24 | 显示全部楼层

您好!

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

--------------------------------------------------
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
-------------------------------------------------------------------------

回复

使用道具 举报

您需要登录后才可以回帖 登录 | 注册

本版积分规则

小黑屋|手机版|Archiver|Excel精英培训 ( 豫ICP备11015029号 )

GMT+8, 2023-2-7 16:37 , Processed in 0.649781 second(s), 9 queries , Gzip On, Yac On.

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

快速回复 返回顶部 返回列表