查看: 3352|回复: 12
求高手进来改下VBA代码，加个自动添加序号功能
阅读权限20
在线时间 小时
要求的表中就是A列加了个序号，E列也加了个序号。并把VBA代码修改下（位置稍微移动下）得到的结果和要求的表一样就好了。谢谢高手了。
注：原来的VBA代码功能：从原数据里筛选出，五个品牌库龄大于30的相同型号的数量求和，库龄取最大值。其它型号的库龄大于60相同型号的数量求和，库龄取最大值。
谢谢。已经解决了！！
[ 本帖最后由 chenjie0510 于
11:29 编辑 ]
阅读权限20
在线时间 小时
::'( ::'( ::'(
阅读权限90
在线时间 小时
& & & & & & & &
原帖由 chenjie0510 于
17:07 发表
::'( ::'( ::'(
Dim r&, i&, rng, arr(1 To 10000, 1 To 3), s%, j As Byte, k%
Application.ScreenUpdating = False
Sheets(1).Select
[a:i] = &&
Sheets(2).Select
&&Cells.Select
& & Selection.Sort Key1:=Range(&C2&), Order1:=xlDescending, Header:=xlGuess, _
& && &&&OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, SortMethod _
& && &&&:=xlPinYin, DataOption1:=xlSortNormal
r = Sheets(2).Range(&a65536&).End(3).Row
Set d = CreateObject(&Scripting.Dictionary&)
For i = 1 To r
& &r2 = Sheets(1).Range(&a65536&).End(3).Row
& &If Cells(i, 3).Value & 30 Then
& && & If Left(Cells(i, 1).Value, 2) = &LG& Or Left(Cells(i, 1).Value, 4) = &MOTO& Or Left(Cells(i, 1).Value, 3) = &诺基亚& Or Left(Cells(i, 1).Value, 2) = &三星& Or Left(Cells(i, 1).Value, 2) = &索爱& Then
& && &&&Range(Cells(i, 1), Cells(i, 3)).Copy Sheets(1).Range(&a& & r2 + 1)
& && &&&Else
& && &&&If Cells(i, 3).Value & 60 Then
& && &&&k = k + 1
& && &&&Range(Cells(i, 1), Cells(i, 3)).Copy Sheets(1).Range(&g& & k)
& && &&&End If
& && & End If
Sheets(1).Select
rng = Sheets(1).Range(&a2&, &c& & Sheets(1).[c65536].End(3).Row)
For s = 1 To UBound(rng)
If d(rng(s, 1)) = && Then
d(rng(s, 1)) = k
For j = 1 To 3
arr(k, j) = rng(s, j)
arr(d(rng(s, 1)), 2) = arr(d(rng(s, 1)), 2) + rng(s, 2)
Sheets(1).[a:c] = &&
Sheets(1).[a1].Resize(k, 3) = arr
d.RemoveAll
'Sheets(1).Select '
rng = Sheets(1).Range(&G2&, &I& & Sheets(1).[I65536].End(3).Row)
For s = 1 To UBound(rng)
If d(rng(s, 1)) = && Then
d(rng(s, 1)) = k
For j = 1 To 3
arr(k, j) = rng(s, j)
arr(d(rng(s, 1)), 2) = arr(d(rng(s, 1)), 2) + rng(s, 2)
Sheets(1).[g:i] = &&
Sheets(1).[g1].Resize(k, 3) = arr
d.RemoveAll
& & Columns(&A:A&).Insert Shift:=xlToRight
& & Range(&A1&) = &1&
& & Range(&A1&).AutoFill Destination:=Range(&A1:A& & Cells(1, 2).End(xlDown).Row), Type:=xlFillSeries
& & Columns(&F:G&).Delete Shift:=xlToLeft
& & Range(&E1&) = &1&
& & Range(&E1&).AutoFill Destination:=Range(&E1:E& & Cells(1, 2).End(xlDown).Row), Type:=xlFillSeries
Application.ScreenUpdating = True
阅读权限20
在线时间 小时
回复 3楼 冰山上的来客 的帖子
谢谢美女啊。可序号有的没啊。[em07]
阅读权限95
在线时间 小时
试试看是否快些:
(31.22 KB, 下载次数: 153)
22:29 上传
点击文件名下载附件
阅读权限20
在线时间 小时
原帖由 zhaogang1960 于
22:29 发表
试试看是否快些:
谢谢，确实快了N多倍。！zhaogang1960 再次谢谢你哈~~~~~~~你真好哦。帮我N次。。。。[em07]
阅读权限20
在线时间 小时
原帖由 zhaogang1960 于
22:29 发表
试试看是否快些:
那个得到的表表格线能不能随数据自动加上啊。
比如说有数据的地方就有边框线了。没有数据的就不需要了。随数据变化~~~[em07]
阅读权限95
在线时间 小时
(29.65 KB, 下载次数: 93)
17:59 上传
点击文件名下载附件
阅读权限20
在线时间 小时
原帖由 zhaogang1960 于
17:59 发表
谢谢。正是想要的。。
阅读权限20
在线时间 小时
原帖由 zhaogang1960 于
17:59 发表
&&[e1].Resize(k, 4) = arr
& & [e1].Resize(k, 4).Borders.LineStyle = xlContinuous
& & Application.ScreenUpdating = True
执行后第4列没有数据会报错。。。
最新热点 /1
ExcelHome每周都有线上直播公开课，
国内一流讲师真身分享，高手贴身答疑，
赶不上直播还能看录像，
关键居然是免费的！
厚木哥们都已经这么努力了，
你还好意思说学不好Office。
玩命加载中，请稍候
玩命加载中，请稍候
Powered by
本论坛言论纯属发表者个人意见，任何违反国家相关法律的言论，本站将协助国家相关部门追究发言者责任！ & & 本站特聘法律顾问：徐怀玉律师 李志群律师查看: 381|回复: 6
求一个修改指定内容下的代码
阅读权限20
在线时间 小时
(6.75 KB, 下载次数: 6)
16:05 上传
点击文件名下载附件
在数据源中建立一张几百条的数据的一张表，然后在修改数据工作薄中修改想要修改的数据。输入姓名，然后修改相应的地址、爱好信息。如果输入姓名与数据源中不相同或者没有这个姓名的，跳出一个信息框提示一下。
阅读权限30
在线时间 小时
新建 Microsoft Excel 工作表 ，请审阅
16:17 上传
点击文件名下载附件
9.57 KB, 下载次数: 10
阅读权限20
在线时间 小时
新建 Microsoft Excel 工作表 ，请审阅
可能我说得不太清楚.我想要的是我在修改数据工作薄中输入姓名,然后再输入我要修改的地址,爱好,然后按修改按钮.在修改前先判断一下我输入的姓名在数据源中是没有,如果没有或者不相同提示一下,修改也不进行下去,如果有的就把地址与爱好这二个修改一下.姓名不动.
阅读权限95
在线时间 小时
& & & & & & & &
Private Sub 修改_Click()
& & Set b = Sheet2.[b:b].Find([b1])
& & If Not b Is Nothing Then
& && &&&b.Offset(0, 1) = [b2]: b.Offset(0, 2) = [b3]
& && &&&MsgBox &查无此人。&
& & End If
用Find函数，代码简单，速度也快。
阅读权限95
在线时间 小时
& & & & & & & &
&&&&&&&&&&&&&&&&&&&&&&&&&
(9.48 KB, 下载次数: 15)
16:31 上传
点击文件名下载附件
阅读权限20
在线时间 小时
&&&&&&&&&&&&&&&&&&&&&&&&&
谢谢.这是我要的.
阅读权限30
在线时间 小时
新建 Microsoft Excel 工作表 (2 ...，改后，请审阅
16:52 上传
点击文件名下载附件
10.12 KB, 下载次数: 3
最新热点 /1
ExcelHome每周都有线上直播公开课，
国内一流讲师真身分享，高手贴身答疑，
赶不上直播还能看录像，
关键居然是免费的！
厚木哥们都已经这么努力了，
你还好意思说学不好Office。
玩命加载中，请稍候
玩命加载中，请稍候
Powered by
本论坛言论纯属发表者个人意见，任何违反国家相关法律的言论，本站将协助国家相关部门追究发言者责任！ & & 本站特聘法律顾问：徐怀玉律师 李志群律师24小时热评
热点排行榜查看: 617|回复: 25
求大神把这VBA代码修改下
阅读权限20
在线时间 小时
& & & & & & & &
想把测试表的VBA下拉菜单挪到实用表用，代码该怎么修改，另外取消B列的下拉菜单的VBA代码，只要A列的VBA下拉菜单代码就够了，哪位大神帮帮忙，谢谢了！
(87.47 KB, 下载次数: 0)
17:20 上传
17:21 上传
点击文件名下载附件
27.1 KB, 下载次数: 8
阅读权限10
在线时间 小时
(34.9 KB, 下载次数: 2)
17:51 上传
点击文件名下载附件
阅读权限95
在线时间 小时
修改OK，请测试核对效果&&&&&&&&&&
17:53 上传
点击文件名下载附件
30.21 KB, 下载次数: 15
阅读权限20
在线时间 小时
修改OK，请测试核对效果&&&&&&&&&&
牛！向大神致敬！谢谢！
阅读权限20
在线时间 小时
谢了，我学习学习
阅读权限20
在线时间 小时
本帖最后由 曹建勇 于
19:18 编辑
修改OK，请测试核对效果&&&&&&&&&&
大神能不能给我看一下这个附件，我想在工程量清单计算表第五列使用你的这个下拉菜单，数据在代码表的第3列，为啥不成功呢
19:17 上传
点击文件名下载附件
161.99 KB, 下载次数: 3
阅读权限95
在线时间 小时
大神能不能给我看一下这个附件，我想在工程量清单计算表第五列使用你的这个下拉菜单，数据在代码表的第3 ...
你漏了东西没拷到吧？&&&&&&&&&&&&
20:09 上传
点击文件名下载附件
225.45 KB, 下载次数: 10
阅读权限20
在线时间 小时
本帖最后由 曹建勇 于
07:59 编辑
你漏了东西没拷到吧？&&&&&&&&&&&&
大神，你注释掉的那段代码是用于C、D列联动下拉菜单的，有用，现在因为加入你的那段代码后，产生了二义性名称冲突，想请你修改下代码、让C、D列联动下拉菜单和E列的单列下拉菜单同时有效。请你帮忙。
如果注释掉你的那段代码，你就会发现C、D列的联动下拉菜单有效，同理，注释掉C、D列的联动下拉菜单代码，你的E列单列下拉菜单有效。我想让这两段代码同时有效，怎么修改代码。费心了！
(28.37 KB, 下载次数: 0)
07:55 上传
阅读权限95
在线时间 小时
晚上有时间帮你看看，现在是手机上网。
阅读权限20
在线时间 小时
好的，多谢。
最新热点 /1
ExcelHome每周都有线上直播公开课，
国内一流讲师真身分享，高手贴身答疑，
赶不上直播还能看录像，
关键居然是免费的！
厚木哥们都已经这么努力了，
你还好意思说学不好Office。
玩命加载中，请稍候
玩命加载中，请稍候
Powered by
本论坛言论纯属发表者个人意见，任何违反国家相关法律的言论，本站将协助国家相关部门追究发言者责任！ & & 本站特聘法律顾问：徐怀玉律师 李志群律师}