|
楼主 |
发表于 2013-5-14 16:06
|
显示全部楼层
本帖最后由 a8737461 于 2013-5-14 16:08 编辑
dajiahaoxinku12 发表于 2013-4-30 22:18
感谢分享,能否分享下vb代码 以下就是我的主要代码了,其实就是把工作表移动到汇总工作簿中并命名
Sub Main()
Dim xlApp As Object
Dim sht As Worksheet
Dim wb As EXCEL.Workbook
Dim ZWB As EXCEL.Workbook
Dim sP, eP, WBPATH, wbname, listWb As String
Dim shtcount, wbcount As Integer
Dim TABLE, tableSht As String
On Error Resume Next
If Me.COM1 <> "" Then
TABLE = Trim(Split(Me.COM1, ":")(0))
tableSht = Trim(Split(Me.COM1, ":")(1))
End If
If Dir(App.Path & "\MODULE\" & TABLE & ".xls") = "" Then
MsgBox "对不起,你所选择的模板表不存在!"
Exit Sub
End If
Set xlApp = GetObject(, "excel.Application")
If Err Then
Else
For Each wb In xlApp.Workbooks
listWb = listWb & vbCrLf & wb.FullName
Next
If MsgBox("目前打开的工作簿有:" & vbCrLf & listWb & vbCrLf & "将强行关闭!", vbYesNo) = vbYes Then
xlApp.Workbooks.Close
xlApp.Quit
Else
Exit Sub
End If
End If
Set xlApp = CreateObject("Excel.application")
'xlApp.Visible = True
AP = App.Path & "\MODULE\" & TABLE & ".xls"
sP = App.Path & "\result\" & TABLE & ".xls"
WBPATH = App.Path & "\各单位明细"
FileCopy AP, sP
Set ZWB = xlApp.Workbooks.Open(sP)
WBPATH = App.Path & "\各单位明细\"
f = Dir(WBPATH & "*.xls")
m = 2
Do While f > " "
'MsgBox (f)
J = 0
Set wb = Workbooks.Open(WBPATH & f)
wbname = wb.Name
DoEvents
lbl.Caption = "正在处理:" & wbname
DoEvents
'MsgBox (wb.Name)
shtcount = wb.Sheets.Count
For Each sht In wb.Sheets
If VBA.Trim(sht.Name) = tableSht Then
J = 1
sht.Name = Replace(wbname, ".xls", "")
'sht.Copy , AFTER:=ZWB.Sheets("A")
sht.Copy , ZWB.Sheets("A")
End If
Next
'判断是否存在
ZWB.Sheets("各名称").Cells(m, 2) = Replace(wbname, ".xls", "")
ZWB.Sheets("各名称").Cells(m, 1) = m - 1
If J = 0 Then
ZWB.Sheets("各名称").Cells(m, 3) = "没有" & tableSht
Else
ZWB.Sheets("各名称").Cells(m, 3) = "Yes"
End If
m = m + 1
'关闭工作表
wb.Close False
f = Dir
Loop
Set sht = Nothing
ZWB.Close True
xlApp.Visible = True
xlApp.Quit
Set ZWB = Nothing
Set xlApp = Nothing
Me.lbl.Caption = "完成"
MsgBox "请到result文件夹中查看结果!"
Unload Me
End Sub
Sub Main()
Dim xlApp As Object
Dim sht As Worksheet
Dim wb As EXCEL.Workbook
Dim ZWB As EXCEL.Workbook
Dim sP, eP, WBPATH, wbname, listWb As String
Dim shtcount, wbcount As Integer
Dim TABLE, tableSht As String
On Error Resume Next
If Me.COM1 <> "" Then
TABLE = Trim(Split(Me.COM1, ":")(0))
tableSht = Trim(Split(Me.COM1, ":")(1))
End If
If Dir(App.Path & "\MODULE\" & TABLE & ".xls") = "" Then
MsgBox "对不起,你所选择的模板表不存在!"
Exit Sub
End If
Set xlApp = GetObject(, "excel.Application")
If Err Then
Else
For Each wb In xlApp.Workbooks
listWb = listWb & vbCrLf & wb.FullName
Next
If MsgBox("目前打开的工作簿有:" & vbCrLf & listWb & vbCrLf & "将强行关闭!", vbYesNo) = vbYes Then
xlApp.Workbooks.Close
xlApp.Quit
Else
Exit Sub
End If
End If
Set xlApp = CreateObject("Excel.application")
'xlApp.Visible = True
AP = App.Path & "\MODULE\" & TABLE & ".xls"
sP = App.Path & "\result\" & TABLE & ".xls"
WBPATH = App.Path & "\各单位明细"
FileCopy AP, sP
Set ZWB = xlApp.Workbooks.Open(sP)
WBPATH = App.Path & "\各单位明细\"
f = Dir(WBPATH & "*.xls")
m = 2
Do While f > " "
'MsgBox (f)
J = 0
Set wb = Workbooks.Open(WBPATH & f)
wbname = wb.Name
DoEvents
lbl.Caption = "正在处理:" & wbname
DoEvents
'MsgBox (wb.Name)
shtcount = wb.Sheets.Count
For Each sht In wb.Sheets
If VBA.Trim(sht.Name) = tableSht Then
J = 1
sht.Name = Replace(wbname, ".xls", "")
'sht.Copy , AFTER:=ZWB.Sheets("A")
sht.Copy , ZWB.Sheets("A")
End If
Next
'判断是否存在
ZWB.Sheets("各名称").Cells(m, 2) = Replace(wbname, ".xls", "")
ZWB.Sheets("各名称").Cells(m, 1) = m - 1
If J = 0 Then
ZWB.Sheets("各名称").Cells(m, 3) = "没有" & tableSht
Else
ZWB.Sheets("各名称").Cells(m, 3) = "Yes"
End If
m = m + 1
'关闭工作表
wb.Close False
f = Dir
Loop
Set sht = Nothing
ZWB.Close True
xlApp.Visible = True
xlApp.Quit
Set ZWB = Nothing
Set xlApp = Nothing
Me.lbl.Caption = "完成"
MsgBox "请到result文件夹中查看结果!"
Unload Me
End Sub
|
|