|
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
|
Dim
ExcelApp
'As Excel.Application
Dim
excelSheet
'As Excel.worksheet
Dim
excelBook
'As Excel.workbook
Dim
fso
'As scrīpting.FileSystemObject
' *********************************************************************************************
' 函数说明：创建一个Excel应用程序ExcelApp,并创建一个新的工作薄Workbook;
' 参数说明：无
' 调用方法:
' CreateExcel()
' *********************************************************************************************
Function
CreateExcel()
'As Excel.Application
Dim
excelSheet
'As Excel.worksheet
Set
ExcelApp = CreateObject(
"Excel.Application"
)
'Create a new excel Object
ExcelApp.Workbooks.Add
ExcelApp.Visible =
True
Set
CreateExcel = ExcelApp
End
Function
' *********************************************************************************************
' 函数说明：关闭Excel应用程序;
' 参数说明：
' (1)ExcelApp:Excel应用程序名称;
' 调用方法:
' CloseExcel(ExcelApp)
' *********************************************************************************************
Sub
CloseExcel(ExcelApp)
Set
excelSheet = ExcelApp.ActiveSheet
Set
excelBook = ExcelApp.ActiveWorkbook
Set
fso = CreateObject(
"Scripting.FileSystemObject"
)
On
Error
Resume
Next
fso.CreateFolder
"C:\Temp"
fso.DeleteFile
"C:\Temp\ExcelExamples.xls"
excelBook.SaveAs
"C:\Temp\ExcelExamples.xls"
ExcelApp.Quit
Set
ExcelApp =
Nothing
Set
fso =
Nothing
Err = 0
On
Error
GoTo
0
End
Sub
' *********************************************************************************************
' 函数说明：保存工作薄;
' 参数说明：
' (1)ExcelApp:Excel应用程序名称;
' (2)workbookIdentifier:属于ExcelApp的工作薄名称;
' (3)path:保存的路径;
' 返回结果：
' (1)保存成功，返回字符串：OK
' (2)保存失败，返回字符串：Bad Worksheet Identifier
' 调用方法:
' ret = SaveWorkbook(ExcelApp, "Book1", "D:\Example1.xls")
' *********************************************************************************************
Function
SaveWorkbook(ExcelApp, workbookIdentifier, path)
'As String
Dim
workbook
'As Excel.workbook
On
Error
Resume
Next
'启用错误处理程序
Set
workbook = ExcelApp.Workbooks(workbookIdentifier)
On
Error
GoTo
0
'禁用错误处理程序
If
Not
workbook
Is
Nothing
Then
If
path =
""
Or
path = workbook.FullName
Or
path = workbook.Name
Then
workbook.Save
Else
Set
fso = CreateObject(
"Scripting.FileSystemObject"
)
'判断路径中是否已添加扩展名.xls
If
InStr(path,
"."
) = 0
Then
path = path &
".xls"
End
If
'删除路径下现有同名的文件
On
Error
Resume
Next
fso.DeleteFile path
Set
fso =
Nothing
Err = 0
On
Error
GoTo
0
workbook.SaveAs path
End
If
SaveWorkbook =
"OK"
Else
SaveWorkbook =
"Bad Workbook Identifier"
End
If
End
Function
' *********************************************************************************************
' 函数说明：设置工作表excelSheet单元格的值
' 参数说明：
' (1)excelSheet:工作表名称;
' (2)row:列的序号,第一列为1;
' (3)column:行的序号,第一行为1;
' (4)value:单元格要设置的值;
' 返回结果：
' 无返回值
' 调用方法:
' SetCellValue excelSheet1, 1, 2, "test"
' *********************************************************************************************
Sub
SetCellValue(excelSheet, row, column, value)
On
Error
Resume
Next
excelSheet.Cells(row, column) = value
On
Error
GoTo
0
End
Sub
'The GetCellValue returns the cell's value according to its row column and sheet
'excelSheet - the Excel Sheet in which the cell exists
'row - the cell's row
'column - the cell's column
'return 0 if the cell could not be found
' *********************************************************************************************
' 函数说明：获取工作表excelSheet单元格的值
' 参数说明：
' (1)excelSheet:工作表名称;
' (2)row:列的序号;
' (3)column:行的序号;
' 返回结果：
' (1)单元格存在,返回单元格值;
' (2)单元格不存在，返回0;
' 调用方法:
' set CellValue = GetCellValue(excelSheet, 1, 2)
' *********************************************************************************************
Function
GetCellValue(excelSheet, row, column)
value = 0
Err = 0
On
Error
Resume
Next
tempValue = excelSheet.Cells(row, column)
If
Err = 0
Then
value = tempValue
Err = 0
End
If
On
Error
GoTo
0
GetCellValue = value
End
Function
' *********************************************************************************************
' 函数说明：获取并返回工作表对象
' 参数说明：
' (1)ExcelApp:Excel应用程序名称;
' (2)sheetIdentifier:属于ExcelApp的工作表名称;
' 返回结果：
' (1)成功：工作表对象Excel.worksheet
' (1)失败：Nothing
' 调用方法:
' Set excelSheet1 = GetSheet(ExcelApp, "Sheet Name")
' *********************************************************************************************
Function
GetSheet(ExcelApp, sheetIdentifier)
On
Error
Resume
Next
Set
GetSheet = ExcelApp.Worksheets.Item(sheetIdentifier)
On
Error
GoTo
0
End
Function
' *********************************************************************************************
' 函数说明：添加一张新的工作表
' 参数说明：
' (1)ExcelApp:Excel应用程序名称;
' (2)workbookIdentifier:属于ExcelApp的工作薄名称;
' (2)sheetName:要插入的工作表名称;
' 返回结果：
' (1)成功：工作表对象worksheet
' (1)失败：Nothing
' 调用方法:
' InsertNewWorksheet(ExcelApp, workbookIdentifier, "new sheet")
' *********************************************************************************************
Function
InsertNewWorksheet(ExcelApp, workbookIdentifier, sheetName)
Dim
workbook
'As Excel.workbook
Dim
worksheet
'As Excel.worksheet
'如果指定的工作薄不存在，将在当前激活状态的工作表中添加工作表
If
workbookIdentifier =
""
Then
Set
workbook = ExcelApp.ActiveWorkbook
Else
On
Error
Resume
Next
Err = 0
Set
workbook = ExcelApp.Workbooks(workbookIdentifier)
If
Err <> 0
Then
Set
InsertNewWorksheet =
Nothing
Err = 0
Exit
Function
End
If
On
Error
GoTo
0
End
If
sheetCount = workbook.Sheets.Count
'获取工作薄中工作表的数量
workbook.Sheets.Add , sheetCount
'添加工作表
Set
worksheet = workbook.Sheets(sheetCount + 1)
'初始化worksheet为新添加的工作表对象
'设置新添加的工作表名称
If
sheetName <>
""
Then
worksheet.Name = sheetName
End
If
Set
InsertNewWorksheet = worksheet
End
Function
' *********************************************************************************************
' 函数说明：修改工作表的名称;
' 参数说明：
' (1)ExcelApp:Excel应用程序名称;
' (2)workbookIdentifier:属于ExcelApp的工作薄名称;
' (3)worksheetIdentifier:属于workbookIdentifier工作薄的工作表名称;
' (4)sheetName:修改后的工作表名称;
' 返回结果：
' (1)修改成功，返回字符串：OK
' (2)修改失败，返回字符串：Bad Worksheet Identifier
' 调用方法:
' set ret = RenameWorksheet(ExcelApp, "Book1", "Sheet1", "Sheet Name")
' *********************************************************************************************
Function
RenameWorksheet(ExcelApp, workbookIdentifier, worksheetIdentifier, sheetName)
Dim
workbook
'As Excel.workbook
Dim
worksheet
'As Excel.worksheet
On
Error
Resume
Next
Err = 0
Set
workbook = ExcelApp.Workbooks(workbookIdentifier)
If
Err <> 0
Then
RenameWorksheet =
"Bad Workbook Identifier"
Err = 0
Exit
Function
End
If
Set
worksheet = workbook.Sheets(worksheetIdentifier)
If
Err <> 0
Then
RenameWorksheet =
"Bad Worksheet Identifier"
Err = 0
Exit
Function
End
If
worksheet.Name = sheetName
RenameWorksheet =
"OK"
End
Function
' *********************************************************************************************
' 函数说明：删除工作表;
' 参数说明：
' (1)ExcelApp:Excel应用程序名称;
' (2)workbookIdentifier:属于ExcelApp的工作薄名称;
' (3)worksheetIdentifier:属于workbookIdentifier工作薄的工作表名称;
' 返回结果：
' (1)删除成功，返回字符串：OK
' (2)删除失败，返回字符串：Bad Worksheet Identifier
' 调用方法:
' set ret = RemoveWorksheet(ExcelApp, "Book1", "Sheet1")
' *********************************************************************************************
Function
RemoveWorksheet(ExcelApp, workbookIdentifier, worksheetIdentifier)
'As String
Dim
workbook
'As Excel.workbook
Dim
worksheet
'As Excel.worksheet
On
Error
Resume
Next
Err = 0
Set
workbook = ExcelApp.Workbooks(workbookIdentifier)
If
Err <> 0
Then
RemoveWorksheet =
"Bad Workbook Identifier"
Exit
Function
End
If
Set
worksheet = workbook.Sheets(worksheetIdentifier)
If
Err <> 0
Then
RemoveWorksheet =
"Bad Worksheet Identifier"
Exit
Function
End
If
worksheet.Delete
RemoveWorksheet =
"OK"
End
Function
' *********************************************************************************************
' 函数说明：添加新的工作薄
' 参数说明：
' (1)ExcelApp:Excel应用程序名称;
' 返回结果：
' (1)成功：工作表对象NewWorkbook
' (1)失败：Nothing
' 调用方法:
' set NewWorkbook = CreateNewWorkbook(ExcelApp)
' *********************************************************************************************
Function
CreateNewWorkbook(ExcelApp)
Set
NewWorkbook = ExcelApp.Workbooks.Add()
Set
CreateNewWorkbook = NewWorkbook
End
Function
' *********************************************************************************************
' 函数说明：打开工作薄
' 参数说明：
' (1)ExcelApp:Excel应用程序名称;
' (2)path:要打开的工作薄路径;
' 返回结果：
' (1)成功：工作表对象NewWorkbook
' (1)失败：Nothing
' 调用方法:
' set NewWorkbook = CreateNewWorkbook(ExcelApp)
' *********************************************************************************************
Function
OpenWorkbook(ExcelApp, path)
On
Error
Resume
Next
Set
NewWorkbook = ExcelApp.Workbooks.Open(path)
Set
OpenWorkbook = NewWorkbook
On
Error
GoTo
0
End
Function
' *********************************************************************************************
' 函数说明：将工作薄设置为当前工作状态
' 参数说明：
' (1)ExcelApp:Excel应用程序名称;
' (2)workbookIdentifier:要设置为当前工作状态的工作薄名称;
' 返回结果：无返回值;
' 调用方法:
' ActivateWorkbook(ExcelApp, workbook1)
' *********************************************************************************************
Sub
ActivateWorkbook(ExcelApp, workbookIdentifier)
On
Error
Resume
Next
ExcelApp.Workbooks(workbookIdentifier).Activate
On
Error
GoTo
0
End
Sub
' *********************************************************************************************
' 函数说明：关闭Excel工作薄;
' 参数说明：
' (1)ExcelApp:Excel应用程序名称;
' (2)workbookIdentifier:
' 调用方法:
' CloseWorkbook(ExcelApp, workbookIdentifier)
' *********************************************************************************************
Sub
CloseWorkbook(ExcelApp, workbookIdentifier)
On
Error
Resume
Next
ExcelApp.Workbooks(workbookIdentifier).Close
On
Error
GoTo
0
End
Sub
' *********************************************************************************************
' 函数说明：判断两个工作表对应单元格内容是否相等
' 参数说明：
' (1)sheet1:工作表1的名称;
' (2)sheet2:工作表2的名称;
' (3)startColumn:开始比较的行序号;
' (4)numberOfColumns:要比较的行数;
' (5)startRow:开始比较的列序号;
' (6)numberOfRows:要比较的列数;
' (7)trimed:是否先除去字符串开始的空格和尾部空格后再进行比较,true或flase;
' 返回结果：
' (1)两工作表对应单元格内容相等：true
' (2)两工作表对应单元格内容不相等:flase
' 调用方法:
' ret = CompareSheets(excelSheet1, excelSheet2, 1, 10, 1, 10, False)
' *********************************************************************************************
Function
CompareSheets(sheet1, sheet2, startColumn, numberOfColumns, startRow, numberOfRows, trimed)
Dim
returnVal
'As Boolean
returnVal =
True
'判断两个工作表是否都存在,任何一个不存在停止判断，返回flase
If
sheet1
Is
Nothing
Or
sheet2
Is
Nothing
Then
CompareSheets =
False
Exit
Function
End
If
'循环判断两个工作表单元格的值是否相等
For
r = startRow to (startRow + (numberOfRows - 1))
For
c = startColumn to (startColumn + (numberOfColumns - 1))
Value1 = sheet1.Cells(r, c)
Value2 = sheet2.Cells(r, c)
'如果trimed为true,去除单元格内容前面和尾部空格
If
trimed
Then
Value1 = Trim(Value1)
Value2 = Trim(Value2)
End
If
'如果单元格内容不一致,函数返回flase
If
Value1 <> Value2
Then
Dim
cell
'As Excel.Range
'修改sheet2工作表中对应单元格值
sheet2.Cells(r, c) =
"Compare conflict - Value was '"
& Value2 &
"', Expected value is '"
& Value1 &
"'."
'初始化cell为sheet2中r:c单元格对象
Set
cell = sheet2.Cells(r, c)
'
'将sheet2工作表中对应单元格的颜色设置为红色
cell.Font.Color = vbRed
returnVal =
False
End
If
Next
Next
CompareSheets = returnVal
End
Function
' ****************************************** VBS控制Excel的一些常见方法***********************************************************
'(一) 使用动态创建的方法
'首先创建 Excel 对象，使用ComObj:
Set
oExcel = CreateObject(
"Excel.Application"
)
'1) 显示当前窗口：
oExcel.Visible =
True
'2) 更改 Excel 标题栏：
oExcel.Caption =
"应用程序调用 Microsoft Excel"
'3) 添加新工作簿：
oExcel.WorkBooks.Add
'4) 打开已存在的工作簿：
oExcel.WorkBooks.Open(
"C:\Excel\Demo.xls"
)
'5) 设置第2个工作表为活动工作表：
oExcel.WorkSheets(2).Activate
或
oExcel.WorksSheets(
"Sheet2"
).Activate
'6) 给单元格赋值：
oExcel.Cells(1,4).Value =
"第一行第四列"
'7) 设置指定列的宽度（单位：字符个数），以第一列为例：
oExcel.ActiveSheet.Columns(1).ColumnsWidth = 5
'8) 设置指定行的高度（单位：磅）（1磅＝0.035厘米），以第二行为例：
oExcel.ActiveSheet.Rows(2).RowHeight = 1/0.035
' 1厘米
'9) 在第8行之前插入分页符：
oExcel.WorkSheets(1).Rows(8).PageBreak = 1
'10) 在第8列之前删除分页符：
oExcel.ActiveSheet.Columns(4).PageBreak = 0
'11) 指定边框线宽度：
oExcel.ActiveSheet.Range(
"B3:D4"
).Borders(2).Weight = 3
'1-左 2-右 3-顶 4-底 5-斜( \ ) 6-斜( / )
'12) 清除第一行第四列单元格公式：
oExcel.ActiveSheet.Cells(1,4).ClearContents
'13) 设置第一行字体属性：
oExcel.ActiveSheet.Rows(1).Font.Name =
"隶书"
oExcel.ActiveSheet.Rows(1).Font.Color = clBlue
oExcel.ActiveSheet.Rows(1).Font.Bold =
True
oExcel.ActiveSheet.Rows(1).Font.UnderLine =
True
'14) 进行页面设置：
'a.页眉：
oExcel.ActiveSheet.PageSetup.CenterHeader =
"报表演示"
'b.页脚：
oExcel.ActiveSheet.PageSetup.CenterFooter =
"第&P页"
'c.页眉到顶端边距2cm：
oExcel.ActiveSheet.PageSetup.HeaderMargin = 2/0.035
'd.页脚到底端边距3cm：
oExcel.ActiveSheet.PageSetup.HeaderMargin = 3/0.035
'e.顶边距2cm：
oExcel.ActiveSheet.PageSetup.TopMargin = 2/0.035
'f.底边距2cm：
oExcel.ActiveSheet.PageSetup.BottomMargin = 2/0.035
'g.左边距2cm：
oExcel.ActiveSheet.PageSetup.LeftMargin = 2/0.035
'h.右边距2cm：
oExcel.ActiveSheet.PageSetup.RightMargin = 2/0.035
'i.页面水平居中：
oExcel.ActiveSheet.PageSetup.CenterHorizontally = 2/0.035
'j.页面垂直居中：
oExcel.ActiveSheet.PageSetup.CenterVertically = 2/0.035
'k.打印单元格网线：
oExcel.ActiveSheet.PageSetup.PrintGridLines =
True
'15) 拷贝操作：
'a.拷贝整个工作表：
oExcel.ActiveSheet.Used.Range.Copy
'b.拷贝指定区域：
oExcel.ActiveSheet.Range(
"A1:E2"
).Copy
'c.从A1位置开始粘贴：
oExcel.ActiveSheet.Range.(
"A1"
).PasteSpecial
'd.从文件尾部开始粘贴：
oExcel.ActiveSheet.Range.PasteSpecial
'16) 插入一行或一列：
'a. 插入一行
oExcel.ActiveSheet.Rows(2).Insert
'b. 插入一列
oExcel.ActiveSheet.Columns(1).Insert
'17) 删除一行或一列：
'a. 删除一行
oExcel.ActiveSheet.Rows(2).Delete
'b. 删除一列
oExcel.ActiveSheet.Columns(1).Delete
'18) 打印预览工作表：
oExcel.ActiveSheet.PrintPreview
'19) 打印输出工作表：
oExcel.ActiveSheet.PrintOut
'20) 工作表保存：
if not oExcel.ActiveWorkBook.Saved then
oExcel.ActiveWorkBook.save
'21) 工作表另存为：
oExcel.ActiveWorkBook.SaveAs(
"C:\Excel\Demo1.xls"
)
'22) 放弃存盘：
oExcel.ActiveWorkBook.Saved =
True
'23) 关闭工作簿：
oExcel.WorkBooks.Close
'24) 退出 Excel：
oExcel.Quit
'(二) 使用VBS 控制Excle二维图
'1）选择当第一个工作薄第一个工作表
set oSheet=oExcel.Workbooks(1).Worksheets(1)
'2）增加一个二维图
achart=oSheet.chartobjects.add(100,100,200,200)
'3）选择二维图的形态
achart.chart.charttype=4
'4）给二维图赋值
set series=achart.chart.seriescollection
range=
"sheet1!r2c3:r3c9"
series.add range,true
'5）加上二维图的标题
achart.Chart.HasTitle=
True
achart.Chart.ChartTitle.Characters.Text=
" Excle二维图"
'6）改变二维图的标题字体大小
achart.Chart.ChartTitle.Font.size=18
'7）给二维图加下标说明
achart.Chart.Axes(xlCategory, xlPrimary).HasTitle =
True
achart.Chart.Axes(xlCategory, xlPrimary).AxisTitle.Characters.Text =
"下标说明"
'8）给二维图加左标说明
achart.Chart.Axes(xlValue, xlPrimary).HasTitle =
True
achart.Chart.Axes(xlValue, xlPrimary).AxisTitle.Characters.Text =
"左标说明"
'9）给二维图加右标说明
achart.Chart.Axes(xlValue, xlSecondary).HasTitle =
True
achart.Chart.Axes(xlValue, xlSecondary).AxisTitle.Characters.Text =
"右标说明"
'10）改变二维图的显示区大小
achart.Chart.PlotArea.Left = 5
achart.Chart.PlotArea.Width = 223
achart.Chart.PlotArea.Height = 108
|
如何使用vbs来遍历excel文件：
|
1
2
3
4
5
6
7
8
|
'获得脚本当前路径
Set
test = createobject(
"Scripting.FileSystemObject"
).GetFolder(".")
Set
fso = createobject(
"Scripting.FileSystemObject"
)
for
Each
i in test.Files
if LCase(fso.GetExtensionName(i)) =
"xlsx"
Then
msgbox i.Name
end if
Next
|
扫一扫
943
被折叠的 条评论
为什么被折叠?
到【灌水乐园】发言
