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

Excel精英培训网

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

[已解决]帮忙一下，高手们

[复制链接]
发表于 2012-11-27 22:45 | 显示全部楼层 |阅读模式
工作中常用的Excel函数公式，全印在一张超大鼠标垫上
大家帮忙一下写个Vba ，把A列含有数据，（"M97,*"  或"M98*"）因为有的时候会有A列会出现“M98*”当然它们不会一起出现，故把这条件考虑进去。把这数据提取放A列%以下，它不能单独移动，要一组移动，一组是T*与T* 上下相邻  ，如T1一组是与T1与T2之间 A列A9，A10。或T与M30 相邻为一组（M30是结束意思）结果如B列，如把C列数据源运行如D列结果，2：M97带有星号键的坐标点以下下一坐标11565Y-094306复制在E1.
3：用F1数据代替M97带有星号键数据。A列最后结果如G,列。C列如H列。
最佳答案
月排行榜 / 总排行榜
hwc2ycy
2012-11-30 09:14
  1. Sub 移位3()
  2.     Dim str1$, str2$, str$, strper$
  3.     Dim pos1&, pos2&, pos3&, posper&, pos&
  4.     Dim i&, i3&
  5.         
  6.     str1 = "M97,~*"
  7.     str2 = "M98,~*"
  8.     strper = "%"
  9.     Application.ScreenUpdating = False
  10.     On Error Resume Next
  11.     pos1 = CBool(Range("a:a").Find(str1, LookIn:=xlValues, lookat:=xlWhole).Row)
  12.     pos2 = CBool(Range("a:a").Find(str2, LookIn:=xlValues, lookat:=xlWhole).Row)
  13.     Err.Clear
  14.    
  15.     If pos1 Then
  16.         str = str1
  17.     Else
  18.         str = str2
  19.     End If
  20.    
  21.     pos = Range("a:a").Find(str, LookIn:=xlValues, lookat:=xlWhole).Row
  22.     [e1] = Range("a" & pos + 1)
  23.     posper = Range("a:a").Find(strper, LookIn:=xlValues, lookat:=xlWhole).Row
  24.     If Err.Number <> 0 Then MsgBox "% error": Exit Sub
  25.     i = posper + 1
  26.     Do Until Cells(i, 1) Like "M30" Or Len(Cells(i, 1)) = 0
  27.         If i <= pos Then
  28.             If Cells(i, 1) Like "T?" Or Cells(i, 1) Like "T??" Then
  29.                 If pos3 = 0 Then pos3 = i
  30.                 pos1 = i
  31.             End If
  32.         End If
  33.         If i > pos Then
  34.             If Cells(i, 1) Like "T?" Or Cells(i, 1) Like "T??" Or Cells(i, 1) Like "M30" Then
  35.                 If pos2 = 0 Then pos2 = i - 1
  36.             End If
  37.         End If
  38.         i = i + 1
  39.     Loop
  40.     Range("a" & pos) = Range("f1")
  41.     If pos2 > 0 Then
  42.         Range("a" & pos1 & ":a" & pos2).Cut
  43.         Range("a" & pos3).Insert shift:=xlDown
  44.     Else
  45.         Range("a" & pos1 & ":a" & i - 1).Cut
  46.         Range("a" & pos3).Insert shift:=xlDown
  47.     End If
  48.     Application.CutCopyMode = False
  49.     Application.ScreenUpdating = True
  50. End Sub
复制代码

111.rar

11.49 KB, 下载次数: 17
回复

使用道具 举报

工作中最常用的函数公式，全印在一张超大的鼠标垫上
hwc2ycy
发表于 2012-11-29 16:55 | 显示全部楼层
工作中常用的Excel函数公式，全印在一张超大鼠标垫上
本帖最后由 hwc2ycy 于 2012-11-29 21:19 编辑
  1. Sub 移位2()
  2.     Dim str1$, str2$, str$, strper$
  3.     Dim pos1&, pos2&, pos3&, posper&, pos&
  4.     Dim i&, i3&
  5.         
  6.     str1 = "M97,~*"
  7.     str2 = "M98,~*"
  8.     strper = "%"
  9.     Application.ScreenUpdating = False
  10.     On Error Resume Next
  11.     pos1 = CBool(Range("a:a").Find(str1, LookIn:=xlValues, lookat:=xlWhole).Row)
  12.     pos2 = CBool(Range("a:a").Find(str2, LookIn:=xlValues, lookat:=xlWhole).Row)
  13.     Err.Clear
  14.    
  15.     If pos1 Then
  16.         str = str1
  17.     Else
  18.         str = str2
  19.     End If
  20.    
  21.     pos = Range("a:a").Find(str, LookIn:=xlValues, lookat:=xlWhole).Row
  22.     posper = Range("a:a").Find(strper, LookIn:=xlValues, lookat:=xlWhole).Row
  23.     If Err.Number <> 0 Then MsgBox "% error": Exit Sub
  24.     i = posper + 1
  25.     Do Until Cells(i, 1) Like "M30" Or Len(Cells(i, 1)) = 0
  26.         If i <= pos Then
  27.             If Cells(i, 1) Like "T?" Or Cells(i, 1) Like "T??" Then
  28.                 If pos3 = 0 Then pos3 = i
  29.                 pos1 = i
  30.             End If
  31.         End If
  32.         If i > pos Then
  33.             If Cells(i, 1) Like "T?" Or Cells(i, 1) Like "T??" Or Cells(i, 1) Like "M30" Then
  34.                 If pos2 = 0 Then pos2 = i - 1
  35.             End If
  36.         End If
  37.         i = i + 1
  38.     Loop
  39.     If pos2 > 0 Then
  40.         Range("a" & pos1 & ":a" & pos2).Cut
  41.         Range("a" & pos3).Insert shift:=xlDown
  42.     Else
  43.         Range("a" & pos1 & ":a" & i - 1).Cut
  44.         Range("a" & pos3).Insert shift:=xlDown
  45.     End If
  46.     Application.CutCopyMode = False
  47.     Application.ScreenUpdating = True
  48. End Sub
复制代码
回复

使用道具 举报

 楼主| 发表于 2012-11-29 19:56 | 显示全部楼层
工作中最常用的Excel函数公式，全印在一张鼠标垫上
hwc2ycy 发表于 2012-11-29 16:55

还不能执行， 谢谢你的
大家帮忙一下写个Vba ，把A列含有数据，（"M97,*"  或"M98*"）因为有的时候会有A列会出现“M98*”当然它们不会一起出现，故把这条件考虑进去。把这数据提取放A列%以下，它不能单独移动，要一组移动，一组是T*与T* 上下相邻  ，如T1一组是与T1与T2之间 A列A9，A10。或T与M30 相邻为一组（M30是结束意思，M30位置不管他们怎么移动，一定要在数据最后面，这一点老师一定帮我考虑进去，得出数据才正确数据，我没表述清楚，抱歉！！！）结果如B列，如把C列数据源运行如D列结果，2：M97带有星号键的坐标点以下下一坐标11565Y-094306复制在E1.
3：用F1数据代替M97带有星号键数据。A列最后结果如G,列。C列如H列。
未命名.JPG
回复

使用道具 举报

hwc2ycy
发表于 2012-11-29 21:19 | 显示全部楼层
你把这个STOP删掉，因为要下班了，测试好了就直接上传了。
回复

使用道具 举报

hwc2ycy
发表于 2012-11-30 09:00 | 显示全部楼层
我后面的都还没写，只写了移动了，替换都还没弄的。昨天是临到下班，先发这的。
回复

使用道具 举报

hwc2ycy
发表于 2012-11-30 09:14 | 显示全部楼层    本楼为最佳答案   
  1. Sub 移位3()
  2.     Dim str1$, str2$, str$, strper$
  3.     Dim pos1&, pos2&, pos3&, posper&, pos&
  4.     Dim i&, i3&
  5.         
  6.     str1 = "M97,~*"
  7.     str2 = "M98,~*"
  8.     strper = "%"
  9.     Application.ScreenUpdating = False
  10.     On Error Resume Next
  11.     pos1 = CBool(Range("a:a").Find(str1, LookIn:=xlValues, lookat:=xlWhole).Row)
  12.     pos2 = CBool(Range("a:a").Find(str2, LookIn:=xlValues, lookat:=xlWhole).Row)
  13.     Err.Clear
  14.    
  15.     If pos1 Then
  16.         str = str1
  17.     Else
  18.         str = str2
  19.     End If
  20.    
  21.     pos = Range("a:a").Find(str, LookIn:=xlValues, lookat:=xlWhole).Row
  22.     [e1] = Range("a" & pos + 1)
  23.     posper = Range("a:a").Find(strper, LookIn:=xlValues, lookat:=xlWhole).Row
  24.     If Err.Number <> 0 Then MsgBox "% error": Exit Sub
  25.     i = posper + 1
  26.     Do Until Cells(i, 1) Like "M30" Or Len(Cells(i, 1)) = 0
  27.         If i <= pos Then
  28.             If Cells(i, 1) Like "T?" Or Cells(i, 1) Like "T??" Then
  29.                 If pos3 = 0 Then pos3 = i
  30.                 pos1 = i
  31.             End If
  32.         End If
  33.         If i > pos Then
  34.             If Cells(i, 1) Like "T?" Or Cells(i, 1) Like "T??" Or Cells(i, 1) Like "M30" Then
  35.                 If pos2 = 0 Then pos2 = i - 1
  36.             End If
  37.         End If
  38.         i = i + 1
  39.     Loop
  40.     Range("a" & pos) = Range("f1")
  41.     If pos2 > 0 Then
  42.         Range("a" & pos1 & ":a" & pos2).Cut
  43.         Range("a" & pos3).Insert shift:=xlDown
  44.     Else
  45.         Range("a" & pos1 & ":a" & i - 1).Cut
  46.         Range("a" & pos3).Insert shift:=xlDown
  47.     End If
  48.     Application.CutCopyMode = False
  49.     Application.ScreenUpdating = True
  50. End Sub
复制代码
回复

使用道具 举报

 楼主| 发表于 2012-11-30 16:18 | 显示全部楼层
本帖最后由 fangniuji 于 2012-12-3 12:25 编辑
hwc2ycy 发表于 2012-11-30 09:14


有点小问题，谢谢看一看，谢谢！！
回复

使用道具 举报

hwc2ycy
发表于 2012-11-30 16:26 | 显示全部楼层
fangniuji 发表于 2012-11-30 16:18
有点小问题，谢谢看一看，谢谢！！

再去发个贴，一贴解一题，
回复

使用道具 举报

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

本版积分规则

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

GMT+8, 2024-4-25 03:42 , Processed in 0.326661 second(s), 10 queries , Gzip On, Yac On.

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

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