最新WPS办公软件学习教程_免费企业办公软件下载_金山WPS Office官网论坛

 找回密码
 
查看: 4721|回复: 8

[VBA/VBS教程] 使用脚本从非结构化的数据源中提取数据填写到非结构化表

[复制链接]

154

主题

28

听众

5098

积分

解答支持团员

Rank: 14Rank: 14Rank: 14Rank: 14

签到天数: 1 天

[LV.1]初来乍到

金币
2784
威望
11087
帖子
2620
精华
0

技术分享团 解答支持团 测试体验团 优秀会员奖 活跃会员奖 乐于助人奖 技巧教程分享达人

发表于 2014-6-26 11:07 |显示全部楼层
分享到: 新浪微博 腾讯微博
原贴和要求在这里:
  b6 P( u* e$ x1 m4 {& r9 ]! r! U( x4 Q5 R
大家好,,请教大家一个较难的问题_最新WPS办公软件学习教程_免费企业办公软件下载_金山WPS Office官网论坛
5 J1 g( C# }' M8 Ehttp://bbs.wps.cn/thread-22429753-1-1.html
7 M& @4 z/ `/ A7 o# E
6 c: q0 c; g$ J8 J5 J在本版谈一下思路:
/ z1 c; p9 _  ?8 w; o问题的要点是怎样获得已知时间、学校、早中晚的人数3 h, ]9 E0 v3 [1 f7 h
教程中主要演示了遍历工作表的所有格子、对字符串的处理、为提高效率对字典的使用
9 O& h/ o2 p) }# V& r* d$ c( \% K. x1 v3 k
首先日期要分析一下字符串:! g4 Q1 I) Q$ X) L
本代码演示了如何将* T5 t- d2 r. S& l
采购日期:2014年 4 月 8 日(周二)

/ z' {) M* H$ l4 d/ _这样一个字符串,变成9 ^& h- W7 h! S! R6 l+ i
8号(周二)
& ?7 @$ U( q2 D& L9 g2 }
3 d0 z  G2 p. _6 L因为要查询的表中,是采用这种形式的。显然它不合理。合理的用法应该是使用时间日期数值。不过这里不管了,就做个字串处理样列
  1. Dim DateStr
  2. DateStr = Workbook.sheets("中晚餐基数表").Range("$A$1").value
  3. DateStr = Replace(DateStr, " ", "")
  4. DateStr = Mid(DateStr, InstrRev(DateStr,"月")+1)
  5. DateStr = Replace(DateStr, "日", "号")
复制代码
上面采用了查找、替换之类的函数,最后处理成需要的格式。
7 ~7 A9 Y. ?8 n! o6 Z7 _7 ?% P+ D5 }7 o* d
然后从A1中获知是午餐还是晚餐。还是一个字串提取函数9 e7 b+ Q4 @+ {2 q& [: T. N

, P. F9 e; h1 ]! X. v3 `1 D( y根据这两个信息,可以确定在源数据表中,它在第几列:
& n7 M# `2 j4 D8 v: j从第2行找那个日期,找到后,再根据早中晚决定加0,1,2
  1. Dim Col
  2. Col = 1
  3. Do While (Trim(SrcSheet.cells(2, col).value) <> Trim(DateStr)) And (col<=SrcMaxCol)
  4.         col=col+1
  5. Loop
  6. If Trim(SrcSheet.cells(2, col).value) <> Trim(DateStr) Then
  7.         MsgBox "没有找到" & DateStr & "的人数"
  8.         WScript.Quit
  9. End If
  10. ' 找到了
  11. Select Case TimeStr
  12.     Case "午餐"        col = col + 1
  13.     Case "晚餐"        col = col + 2
  14. End Select
复制代码
然后从第4行开始,建立一个学校名称和人数的对照字典:
  1. Dim SchoolDic
  2. Set SchoolDic = CreateObject("scripting.dictionary")
  3. Dim Row
  4. row = 4
  5. While SrcSheet.cells(row, 2).value <> ""
  6.         wscript.echo SrcSheet.cells(row, 2) & vbtab & SrcSheet.cells(row, col).Value
  7.         SchoolDic.Add SrcSheet.cells(row, 2).value, SrcSheet.cells(row, col).Value
  8.         row = row + 1
  9. Wend
复制代码
数据已经收集好了。下面填表1 i. F& f& k6 d5 l
分析了一下,怎样填到那个人数格呢?) P! @/ ^) y6 t' }
5 ]6 K$ `6 d3 `8 z
决定从第1列到最后1列,从上到下找填有“学校名称:”的这个格子8 B& a# O# m# T4 W
找到后,这个格子后面一个格子就是学校的名称。
  1. Dim SchoolName, Count, Cellvalue
  2. For col = 1 To MaxCol
  3.         Row =1
  4.         While row < MaxRow
  5.                 On Error Resume Next
  6.                 Cellvalue = Trim(ActiveSheet.Cells(row,col).value)
  7.                 On Error Goto 0       
  8.                 While (Cellvalue <> "学校名称:") And (row < MaxRow)
  9.                     row = row + 1
  10.                         On Error Resume Next
  11.                         Cellvalue = Trim(ActiveSheet.Cells(row,col).value)
  12.                         On Error Goto 0       
  13.                 Wend
  14.                 If Cellvalue = "学校名称:" Then
  15.                         SchoolName = ActiveSheet.Cells(row, col+1).value
  16.                         row = row + 1
  17.                         On Error Resume Next
  18. ……
复制代码
找到学校名称后,继续向下找:学校负责人% h' {# C" U+ h, R7 j: B# m. g
根据这个表格,知道 人数 和 学校负责人在同一行上,找到学校负责人那个格子后,向后数5格,就是我们要填的格子:- q. a3 z* x% D+ S* e
这时根据学校名称,从字典中找到人数,填入
  1.                         While (Cellvalue <> "学校负责人:") And (row < MaxRow)
  2.                                 row = row + 1
  3.                                 On Error Resume Next
  4.                                 Cellvalue = Trim(ActiveSheet.Cells(row,col).value)
  5.                                 On Error Goto 0       
  6.                         Wend
  7.                         Count = SchoolDic.Item(SchoolName)
  8.                         ActiveSheet.Cells(row, col + 5) = Count
  9.                         wscript.echo SchoolName & TimeStr & ": 填写人数" & Count       
复制代码
这样程序完工。! x( q8 r0 J! P3 U# e& w% I
/ M% V* s& r2 k& E0 e1 C
说一下代码中的 On Error Resume Next3 k9 {; n- @) Z6 B- k7 f- B$ u
这是没办法的事,因为表格中有错误,数据不干净,有一些格子是#Ref引用错误,导致程序读值时在这里挂起。只好用这个代码强制忽略。
2 Q1 Y; Q0 B5 u1 L1 h& v' [/ [4 U$ u: J) j; D, M/ X+ W# P
9 X% K& h/ k( Y. q
全部代码:
  1. ' 强制控制台执行
  2. Function IsCScript()
  3.         ' Check whethe CScript.exe is the host.
  4.         If (InStr(UCase(WScript.FullName), "CSCRIPT") <> 0) Then
  5.                 IsCScript = True
  6.         Else
  7.                 IsCScript = False
  8.         End If
  9. End Function
  10. Sub ForceInCScript()
  11.         Dim WshShell
  12.         Set WshShell = WScript.CreateObject("WScript.Shell")
  13.        
  14.         If (Not IsCScript()) Then
  15.                 WshShell.Run "CScript.exe " & """" & WScript.ScriptFullName & """"
  16.                 WScript.Quit ' Terminate script.
  17.         End If
  18. End Sub
  19. ForceInCScript
  20. MsgBox "此程序查找当前的工作表中的“人数”,自动去人数表工作簿中搜索相应数据。所以这两个文件请都用wps et打开,并把要填的表放在前端。" & vbCrLf & vbCrLf & "做好后按确定", vbOKOnly+vbInformation, "重要提示"
  21. ' This code try to connect WPS ET,if failed then connect to Excel
  22. Dim ET
  23. On Error Resume Next
  24. ' try to connect to et or excel
  25. Set ET = GetObject(, "Excel.Application")
  26. If ET Is Nothing Then
  27.         Set ET = GetObject(, "KET.Application")
  28.         If ET Is Nothing Then
  29.                 Set ET = GetObject(, "ET.Application")
  30.                 If ET Is Nothing Then
  31.                         MsgBox "Run Excel or Kingsoft ET first.", vbInformation, "Information"
  32.                         WScript.Quit
  33.                 End If
  34.         End If
  35. End If
  36. On Error Goto 0
  37. Dim Workbook, ActiveSheet
  38. Set Workbook = ET.ActiveWorkbook
  39. Set ActiveSheet = Workbook.ActiveSheet
  40. Dim MaxRow, MaxCol
  41. MaxRow = ActiveSheet.UsedRange.Row + ActiveSheet.UsedRange.Rows.Count-1
  42. MaxCol = ActiveSheet.UsedRange.Column + ActiveSheet.UsedRange.Columns.Count-1
  43. ' 下面确定一下今天的日期,以方便查找
  44. Dim DateStr
  45. DateStr = Workbook.sheets("中晚餐基数表").Range("$A$1").value
  46. DateStr = Replace(DateStr, " ", "")
  47. DateStr = Mid(DateStr, InstrRev(DateStr,"月")+1)
  48. DateStr = Replace(DateStr, "日", "号")
  49. If vbNo = MsgBox ("从基数表中得到的日期是“" & DateStr & "”" & vbCrLf & vbCrLf & "是否正确?如果不正确,选择“否”,程序退出", vbYesNo+vbQuestion, "确认") Then
  50.         WScript.Quit
  51. End If
  52. ' 确定早餐还是午餐还是晚餐
  53. Dim TimeStr
  54. TimeStr = ActiveSheet.Cells(1,1).value
  55. TimeStr = Mid(TimeStr, InstrRev(TimeStr,"餐")-1,2)
  56. If vbNo = MsgBox ("从当前表中得到的餐时是“" & TimeStr & "”" & vbCrLf & vbCrLf & "是否正确?如果不正确,选择“否”,程序退出", vbYesNo+vbQuestion, "确认") Then
  57.         WScript.Quit
  58. End If
  59. Dim SrcWorkbook
  60. Set SrcWorkbook = ET.Workbooks("人数表 工作簿.et")
  61. Set SrcSheet = SrcWorkbook.Sheets(1)
  62. Dim SrcMaxRow, SrcMaxCol
  63. SrcMaxRow = SrcSheet.UsedRange.Row + SrcSheet.UsedRange.Rows.Count-1
  64. SrcMaxCol = SrcSheet.UsedRange.Column + SrcSheet.UsedRange.Columns.Count-1
  65. Dim Col
  66. Col = 1
  67. Do While (Trim(SrcSheet.cells(2, col).value) <> Trim(DateStr)) And (col<=SrcMaxCol)
  68.         col=col+1
  69. Loop
  70. If Trim(SrcSheet.cells(2, col).value) <> Trim(DateStr) Then
  71.         MsgBox "没有找到" & DateStr & "的人数"
  72.         WScript.Quit
  73. End If
  74. ' 找到了
  75. Select Case TimeStr
  76.     Case "午餐"        col = col + 1
  77.     Case "晚餐"        col = col + 2
  78. End Select
  79. Dim SchoolDic
  80. Set SchoolDic = CreateObject("scripting.dictionary")
  81. Dim Row
  82. row = 4
  83. While SrcSheet.cells(row, 2).value <> ""
  84.         wscript.echo SrcSheet.cells(row, 2) & vbtab & SrcSheet.cells(row, col).Value
  85.         SchoolDic.Add SrcSheet.cells(row, 2).value, SrcSheet.cells(row, col).Value
  86.         row = row + 1
  87. Wend
  88. ' 找人数
  89. Dim SchoolName, Count, Cellvalue
  90. For col = 1 To MaxCol
  91.         Row =1
  92.         While row < MaxRow
  93.                 On Error Resume Next
  94.                 Cellvalue = Trim(ActiveSheet.Cells(row,col).value)
  95.                 On Error Goto 0       
  96.                 While (Cellvalue <> "学校名称:") And (row < MaxRow)
  97.                     row = row + 1
  98.                         On Error Resume Next
  99.                         Cellvalue = Trim(ActiveSheet.Cells(row,col).value)
  100.                         On Error Goto 0       
  101.                 Wend
  102.                 If Cellvalue = "学校名称:" Then
  103.                         SchoolName = ActiveSheet.Cells(row, col+1).value
  104.                         row = row + 1
  105.                         On Error Resume Next
  106.                         Cellvalue = Trim(ActiveSheet.Cells(row,col).value)
  107.                         On Error Goto 0       
  108.                         While (Cellvalue <> "学校负责人:") And (row < MaxRow)
  109.                                 row = row + 1
  110.                                 On Error Resume Next
  111.                                 Cellvalue = Trim(ActiveSheet.Cells(row,col).value)
  112.                                 On Error Goto 0       
  113.                         Wend
  114.                         Count = SchoolDic.Item(SchoolName)
  115.                         ActiveSheet.Cells(row, col + 5) = Count
  116.                         wscript.echo SchoolName & TimeStr & ": 填写人数" & Count                       
  117.                 End If                       
  118.         Wend
  119. Next
  120. MsgBox "填写结束"
复制代码

本帖子中包含更多资源

您需要 登录 才可以下载或查看,

已有 3 人评分威望 收起 理由
轩少 + 24 这么好的教程贴,我和我的小伙伴们都惊呆了.
落寞冬日 + 30 小伙伴,我只能给你这么多分了。.
zhouyiran1@126.com + 24 这么好的教程贴,我和我的小伙伴们都惊呆了.

总评分: 威望 + 78   查看全部评分

154

主题

28

听众

5098

积分

解答支持团员

Rank: 14Rank: 14Rank: 14Rank: 14

签到天数: 1 天

[LV.1]初来乍到

金币
2784
威望
11087
帖子
2620
精华
0

技术分享团 解答支持团 测试体验团 优秀会员奖 活跃会员奖 乐于助人奖 技巧教程分享达人

发表于 2014-6-26 11:17 |显示全部楼层
程序演示:( B1 i  M7 M, L: w# M, l
( [9 ^# f2 }; R) r

6 Z3 f$ m6 a  S9 A5 F" C3 m2 o5 v- A$ ]: @& r+ X% u

本帖子中包含更多资源

您需要 登录 才可以下载或查看,

回复

使用道具 举报

153

主题

110

听众

1万

积分

解答支持团长

老菜鸟

Rank: 20Rank: 20Rank: 20Rank: 20Rank: 20

签到天数: 240 天

[LV.8]以坛为家I

金币
1254
威望
25965
帖子
10314
精华
1

活跃会员奖 解答支持团 测试体验团 乐于助人奖 优秀会员奖

发表于 2014-6-26 11:37 |显示全部楼层
哈哈,高手就是不简单!
$ ]' u8 T& D, h% c0 c; A3 H1 k8 C: ~; Q8 F- E8 C! e
果断送高分,顶帖+收藏。
回复

使用道具 举报

78

主题

62

听众

5047

积分

解答支持团长

Rank: 20Rank: 20Rank: 20Rank: 20Rank: 20

该用户从未签到

金币
257
威望
9809
帖子
3187
精华
0

WPS粉丝团 勤奋版主奖 荣誉版主奖 乐于助人奖 优秀会员奖 活跃会员奖 技术分享团 解答支持团 测试体验团 重阳节勋章 技巧教程分享达人 版主勋章

发表于 2014-6-26 17:17 |显示全部楼层
竟然没人来顶。太不科学了。
回复

使用道具 举报

53

主题

60

听众

6715

积分

版主

Rank: 20Rank: 20Rank: 20Rank: 20Rank: 20

签到天数: 126 天

[LV.7]常住居民III

金币
634
威望
13773
帖子
3973
精华
2

WPS粉丝团 技术分享团 乐于助人奖 技巧教程分享达人 优秀会员奖 活跃会员奖 测试体验团 版主勋章 勤奋版主奖 最佳教程奖 测试体验官 优秀模板奖

发表于 2014-6-28 14:09 |显示全部楼层
果断收藏,加分

点击了解最新动态:【轩少】__实用教程索引(2015-9-6更新)
http://bbs.wps.cn/forum.php?mod= ... amp;fromuid=2404273
回复

使用道具 举报

2

主题

0

听众

95

积分

LV.2

Rank: 2

该用户从未签到

金币
1
威望
192
帖子
59
精华
0
发表于 2014-7-1 08:13 |显示全部楼层
我仔细看看这个脚本,,有哪里不懂再请教!!!
回复

使用道具 举报

2

主题

0

听众

95

积分

LV.2

Rank: 2

该用户从未签到

金币
1
威望
192
帖子
59
精华
0
发表于 2014-7-1 08:16 |显示全部楼层
quelea 发表于 2014-6-26 11:17 8 y+ Y) b  [# S" ]2 \
程序演示:
! C% J2 P) Y! G) `7 l9 p
不仅有代码,还有图像,真齐全,我再看看代码哪里不懂再请教,这几天家里有事没有上班,不好意思 。
回复

使用道具 举报

4

主题

2

听众

416

积分

LV.5

Rank: 5Rank: 5

签到天数: 1 天

[LV.1]初来乍到

金币
13
威望
700
帖子
384
精华
0
发表于 2015-6-22 16:07 |显示全部楼层

3 i0 l4 `0 H2 s3 C5 r6 R感谢分享,支持楼主
回复

使用道具 举报

114

主题

20

听众

2万

积分

LV.18

Rank: 18Rank: 18Rank: 18Rank: 18Rank: 18

签到天数: 1241 天

[LV.10]以坛为家III

金币
2140
威望
69257
帖子
4226
精华
0

优秀会员奖 活跃会员奖

发表于 2017-12-24 06:48 |显示全部楼层
看一下            
回复

使用道具 举报

*滑动验证:
您需要登录后才可以回帖 登录 | 更多账号登录:

快速回帖:

fastpost

WPS论坛更新日志|WPS Office官方论坛 ( 粤公网安备 44049102496073号 粤ICP备13015957号-1   

GMT+8, 2018-1-19 19:24

Powered by Discuz! X2.5

© 2001-2012 Comsenz Inc.

回顶部