|
本帖最后由 qiaodong64 于 2017-4-18 23:04 编辑
按顺序执行代码如下:
Sub ppp()
Call set1
Application.Wait (Now + TimeValue("00:00:3")) '3秒后运行宏二
Application.StatusBar = "……程序正在运行,请稍候……"
Call set2
Application.Wait (Now + TimeValue("00:00:3")) '3秒后运行宏三
Application.StatusBar = "……程序正在运行,请稍候……"
Call set3
Application.StatusBar = "程序运行结束"
End Sub
set1代码如下:
Sub set1()
Dim Wb As Workbook, sh As Worksheet, Wbnm As String
Dim Ends As Long, Mypath As String
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Mypath = ThisWorkbook.Path & "\"
Wbnm = Dir(Mypath & "*.xls*")
Do While Wbnm <> ""
If Wbnm = ThisWorkbook.Name Then
Set Wb = ActiveWorkbook
Else
Set Wb = Workbooks.Open(Mypath & Wbnm)
End If
For Each sh In Wb.Worksheets
Ends = sh.Range("v65536").End(3).Row
If sh.Range("v2") <> "1次" Then
sh.Range("v2") = 1
sh.Range("v2").Copy
sh.Range("v3:v" & Ends).PasteSpecial Paste:=xlPasteAll, Operation:=xlMultiply, _
SkipBlanks:=False, Transpose:=False
sh.Range("v2") = "1次"
Wb.Save
End If
If Wbnm <> ThisWorkbook.Name Then Wb.Close
Wbnm = Dir
Next
Loop
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Set Wb = Nothing
End Sub
set2代码如下:
Sub set2()
Dim ph$, fn$, sh As Worksheet
ph = ThisWorkbook.Path & "\"
fn = Dir(ph & "*.xls")
Do While fn <> ""
If fn <> ThisWorkbook.Name Then
With Workbooks.Open(ph & fn)
For Each sh In .Sheets
sh.UsedRange = sh.UsedRange.Value
Next
.Close True
End With
End If
fn = Dir
Loop
End Sub
set3代码如下:
Sub set3()
Dim i As Integer, sh
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Range("a:ap").ClearContents
Filename = Dir(ThisWorkbook.Path & "\*.xls") '在本工作簿所在文件夹下(ThisWorkbook.Path)逐个查找excel文件
Do While Filename <> "" '如果查找到存在第一个,则DO循环查找所有的
If Filename <> ThisWorkbook.Name Then '如果查找到的工作簿名称与本工作簿名称相同,则不进行复制
fn = ThisWorkbook.Path & "\" & Filename '工作簿完整路径及名称,以便下句打开工作簿
Set Wb = Workbooks.Open(fn) '按上述fn值,打开指定文件夹下的工作簿
' For Each sh In wb.Sheets
i = ThisWorkbook.Sheets("汇总").Range("vv3").End(xlToLeft).Column + 1
Range("bf:bf").Copy ThisWorkbook.Sheets("汇总").Cells(1, i)
Application.CutCopyMode = False
' Next
Wb.Close False '数据读取后,关闭打开的工作簿,False表示关闭时不进行保存
End If
Filename = Dir '在当作工作簿所在文件夹下,循环打开下一个工作簿,循环到Do While Filename <> ""那句继续执行
Loop
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
|
|