设为首页收藏本站
开启辅助访问

Excel精英培训网

 找回密码
 注册
Excel精英培训网»论坛 › Excel 求助区 › Excel VBA开发 › 求高手编辑超复杂的VBA
数据透视表40+个常用小技巧，让你一次学会！
返回列表 发新帖
查看: 2324|回复: 3

[已解决]求高手编辑超复杂的VBA

[复制链接]
发表于 2013-10-9 19:46 | 显示全部楼层 |阅读模式
工作中常用的Excel函数公式，全印在一张超大鼠标垫上
QQ20131009174229.jpg
如上图所示，我已经实现第一、二个条件了（附件里的VBA程序里），但因一个工作表里只能设置一下自动运行宏的功能，所以得把所有条件都合并，因能力有限，敬请高手继续在我的原编程里继续补充，实现1~4个条件同时计算，而且都是自动运行（即无须设置控件按扭），谢谢！
最佳答案
月排行榜 / 总排行榜
suye1010
2013-10-25 07:42
  1. Option Explicit

  3. Private Sub Worksheet_Change(ByVal Target As Range)
  4. If Target.Row = 1 Then Exit Sub
  5. Dim i As Long, c As Object, Rng As String, j As Long, s As String
  6. Select Case Target.Column
  7. Case 4
  8.     Target.Offset(, 1).Resize(, 2).ClearContents
  9.     Set c = Sheet2.Columns(1).Find(Target, LookIn:=xlValues, lookat:=xlWhole)
  10.     If Not c Is Nothing Then
  11.         For i = c.Row To Sheet2.[B65536].End(xlUp).Row
  12.             If Sheet2.Cells(i, 1) = "" Or Sheet2.Cells(i, 1) = c Then
  13.                 Rng = Rng & "," & Sheet2.Cells(i, 2)
  14.             Else
  15.                 Exit For
  16.             End If
  17.         Next i
  18.         Rng = Mid(Rng, 2)
  19.         With Target.Offset(, 1).Validation
  20.             .Delete
  21.             .Add 3, 1, 1, Rng
  22.         End With
  23.     End If
  24.     Target.Offset(, 5) = Target.Offset(, 2) * Target.Offset(, 3) * Target.Offset(0, 4)
  25. Case 5
  26.     Target.Offset(, 1).NumberFormatLocal = "@"
  27.     Set c = Sheet2.Columns(2).Find(Target, LookIn:=xlValues, lookat:=xlWhole)
  28.     If Not c Is Nothing Then
  29.         Target.Offset(, 1) = c.Offset(, 1)
  30.     Else
  31.         s = 1
  32.         For j = 1 To Len(Target)
  33.             If Asc(Mid(Target, j, 1)) > 0 Then
  34.                 s = s * Mid(Target, j, 1)
  35.             End If
  36.         Next j
  37.         Target.Offset(, 1) = s
  38.         Target.Offset(, 4) = Target.Offset(, 1) * Target.Offset(, 2) * Target.Offset(0, 3)
  39.     End If
  40. Case 6, 7, 8
  41.     Cells(Target.Row, 9) = Cells(Target.Row, 6) * Cells(Target.Row, 7) * Cells(Target.Row, 8)
  42. End Select
  43. End Sub
复制代码

有条件的下拉菜单2.rar

10.37 KB, 下载次数: 13
回复

使用道具 举报

工作中最常用的函数公式，全印在一张超大的鼠标垫上
发表于 2013-10-9 22:11 | 显示全部楼层
工作中常用的Excel函数公式，全印在一张超大鼠标垫上
  1. Private Sub Worksheet_Change(ByVal Target As Range)
  2. If Target.Row = 1 Then Exit Sub
  3. Dim i As Long, c As Object, Rng As String, j As Long, s As String
  4. Select Case Target.Column
  5. Case 4
  6.     Target.Offset(, 1).Resize(, 2).ClearContents
  7.     Set c = Sheet2.Columns(1).Find(Target, LookIn:=xlValues, lookat:=xlWhole)
  8.     If Not c Is Nothing Then
  9.         For i = c.Row To Sheet2.[B65536].End(xlUp).Row
  10.             If Sheet2.Cells(i, 1) = "" Or Sheet2.Cells(i, 1) = c Then
  11.                 Rng = Rng & "," & Sheet2.Cells(i, 2)
  12.             Else
  13.                 Exit For
  14.             End If
  15.         Next i
  16.         Rng = Mid(Rng, 2)
  17.         With Target.Offset(, 1).Validation
  18.             .Delete
  19.             .Add 3, 1, 1, Rng
  20.         End With
  21.     End If
  22. Case 5
  23.     Target.Offset(, 1).NumberFormatLocal = "@"
  24.     Set c = Sheet2.Columns(2).Find(Target, LookIn:=xlValues, lookat:=xlWhole)
  25.     If Not c Is Nothing Then
  26.         Target.Offset(, 1) = c.Offset(, 1)
  27.     Else
  28.         For j = 1 To Len(Target)
  29.             If Asc(Mid(Target, j, 1)) > 0 Then
  30.                 s = s & Mid(Target, j, 1)
  31.             End If
  32.         Next j
  33.         Target.Offset(, 1) = s
  34.     End If
  35. Case 6
  36.     If Target.Text <> "" Then Target.Offset(, 1) = Target.Offset(, 2) + Target.Offset(0, 3)
  37. End Select
  38. End Sub

复制代码
回复

使用道具 举报

 楼主| 发表于 2013-10-18 17:14 | 显示全部楼层
工作中最常用的Excel函数公式，全印在一张鼠标垫上
能否再精简，实现从后面输入或前面输入，结果都能计算出来，因为按上楼楼术的程序，结果只能实现从前面到后面，而不能实现从后面到前面的改变
回复

使用道具 举报

 楼主| 发表于 2013-10-24 22:01 | 显示全部楼层 |阅读模式
QQ图片20131018175306.jpg 如图所示，如论从前面或后面都能实现自动计算，谢谢！
最佳答案
月排行榜 / 总排行榜
suye1010
2013-10-25 07:42
  1. Option Explicit

  3. Private Sub Worksheet_Change(ByVal Target As Range)
  4. If Target.Row = 1 Then Exit Sub
  5. Dim i As Long, c As Object, Rng As String, j As Long, s As String
  6. Select Case Target.Column
  7. Case 4
  8.     Target.Offset(, 1).Resize(, 2).ClearContents
  9.     Set c = Sheet2.Columns(1).Find(Target, LookIn:=xlValues, lookat:=xlWhole)
  10.     If Not c Is Nothing Then
  11.         For i = c.Row To Sheet2.[B65536].End(xlUp).Row
  12.             If Sheet2.Cells(i, 1) = "" Or Sheet2.Cells(i, 1) = c Then
  13.                 Rng = Rng & "," & Sheet2.Cells(i, 2)
  14.             Else
  15.                 Exit For
  16.             End If
  17.         Next i
  18.         Rng = Mid(Rng, 2)
  19.         With Target.Offset(, 1).Validation
  20.             .Delete
  21.             .Add 3, 1, 1, Rng
  22.         End With
  23.     End If
  24.     Target.Offset(, 5) = Target.Offset(, 2) * Target.Offset(, 3) * Target.Offset(0, 4)
  25. Case 5
  26.     Target.Offset(, 1).NumberFormatLocal = "@"
  27.     Set c = Sheet2.Columns(2).Find(Target, LookIn:=xlValues, lookat:=xlWhole)
  28.     If Not c Is Nothing Then
  29.         Target.Offset(, 1) = c.Offset(, 1)
  30.     Else
  31.         s = 1
  32.         For j = 1 To Len(Target)
  33.             If Asc(Mid(Target, j, 1)) > 0 Then
  34.                 s = s * Mid(Target, j, 1)
  35.             End If
  36.         Next j
  37.         Target.Offset(, 1) = s
  38.         Target.Offset(, 4) = Target.Offset(, 1) * Target.Offset(, 2) * Target.Offset(0, 3)
  39.     End If
  40. Case 6, 7, 8
  41.     Cells(Target.Row, 9) = Cells(Target.Row, 6) * Cells(Target.Row, 7) * Cells(Target.Row, 8)
  42. End Select
  43. End Sub
复制代码

如何编辑自动运行宏1018.rar

3.17 KB, 下载次数: 14
回复

使用道具 举报

发表于 2013-10-25 07:42 | 显示全部楼层    本楼为最佳答案   
  1. Option Explicit

  3. Private Sub Worksheet_Change(ByVal Target As Range)
  4. If Target.Row = 1 Then Exit Sub
  5. Dim i As Long, c As Object, Rng As String, j As Long, s As String
  6. Select Case Target.Column
  7. Case 4
  8.     Target.Offset(, 1).Resize(, 2).ClearContents
  9.     Set c = Sheet2.Columns(1).Find(Target, LookIn:=xlValues, lookat:=xlWhole)
  10.     If Not c Is Nothing Then
  11.         For i = c.Row To Sheet2.[B65536].End(xlUp).Row
  12.             If Sheet2.Cells(i, 1) = "" Or Sheet2.Cells(i, 1) = c Then
  13.                 Rng = Rng & "," & Sheet2.Cells(i, 2)
  14.             Else
  15.                 Exit For
  16.             End If
  17.         Next i
  18.         Rng = Mid(Rng, 2)
  19.         With Target.Offset(, 1).Validation
  20.             .Delete
  21.             .Add 3, 1, 1, Rng
  22.         End With
  23.     End If
  24.     Target.Offset(, 5) = Target.Offset(, 2) * Target.Offset(, 3) * Target.Offset(0, 4)
  25. Case 5
  26.     Target.Offset(, 1).NumberFormatLocal = "@"
  27.     Set c = Sheet2.Columns(2).Find(Target, LookIn:=xlValues, lookat:=xlWhole)
  28.     If Not c Is Nothing Then
  29.         Target.Offset(, 1) = c.Offset(, 1)
  30.     Else
  31.         s = 1
  32.         For j = 1 To Len(Target)
  33.             If Asc(Mid(Target, j, 1)) > 0 Then
  34.                 s = s * Mid(Target, j, 1)
  35.             End If
  36.         Next j
  37.         Target.Offset(, 1) = s
  38.         Target.Offset(, 4) = Target.Offset(, 1) * Target.Offset(, 2) * Target.Offset(0, 3)
  39.     End If
  40. Case 6, 7, 8
  41.     Cells(Target.Row, 9) = Cells(Target.Row, 6) * Cells(Target.Row, 7) * Cells(Target.Row, 8)
  42. End Select
  43. End Sub
复制代码
回复

使用道具 举报

发表于 2013-10-25 09:05 | 显示全部楼层
学习学习
回复

使用道具 举报

xzwdk
发表于 2013-10-25 09:57 | 显示全部楼层
思路很好
回复

使用道具 举报

返回列表 发新帖
高级模式
B Color Image Link Quote Code Smilies
您需要登录后才可以回帖 登录 | 注册

本版积分规则

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

GMT+8, 2024-5-15 10:26 , Processed in 0.134304 second(s), 10 queries , Gzip On, Yac On.

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

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