[已解决]求同一文件夹内汇总表格复制模块

icenotcool · 发表于 2014-3-1 09:44

本帖最后由 icenotcool 于 2014-3-6 15:40 编辑

各位老师，想请老师帮我写一个复制工作表的的模块，详情在附件内，谢谢老师了！附件

举例更新.rar (510.01 KB, 下载次数: 3)

hwc2ycy · 发表于 2014-3-1 10:17

Sub test()
Dim strPath As String, strFile As String
Dim wb As Workbook
Dim strSheet$
Dim strNewSheet$
Dim strMsg$
strSheet = "月度考勤簿"
strPath = ThisWorkbook.Path & Application.PathSeparator
strFile = Dir(strPath & "*.xls")
Application.ScreenUpdating = False
On Error GoTo errorhandle
Do While Len(strFile)
If strFile <> ThisWorkbook.Name And strFile Like "*.xls" Then
'找到文件后执行的操作
Set wb = GetObject(strPath & strFile)
If SheetIsExist(wb, strSheet) Then
strNewSheet = Replace(strFile, ".xls", "")
If Not SheetIsExist(ThisWorkbook, strNewSheet) Then
Worksheets.Add after:=Worksheets(Worksheets.Count)
ActiveSheet.Name = strNewSheet
End If
wb.Worksheets(strSheet).UsedRange.Copy Worksheets(strNewSheet).Range("a1")
Else
strMsg = strMsg & "工作簿 " & strFile & " 内没有工作表 " & strSheet
End If
wb.Close False
End If
strFile = Dir
Loop
Application.ScreenUpdating = True
If Len(strMsg) = 0 Then strMsg = "汇总完成"
MsgBox strMsg
Exit Sub
errorhandle:
If MsgBox("错误代码：" & Err.Number & vbCr & _
"错误描述：" & Err.Description & vbCr & vbCr & _
"忽略错误，点击是，结束点击否", vbYesNo + vbDefaultButton1, "出错了") = vbYes Then
Resume Next
Else
On Error Resume Next
wb.Close False
Application.ScreenUpdating = True
End If
End Sub
Function SheetIsExist(wb As Workbook, index)
On Error Resume Next
SheetIsExist = Len(wb.Worksheets(index).Name) > 0
End Function

复制代码

hwc2ycy · 发表于 2014-3-1 10:21

改了下。

Sub test()
Dim strPath As String, strFile As String
Dim wb As Workbook
Dim strSheet$
Dim strNewSheet$
Dim strMsg$
strSheet = "月度考勤簿"
strPath = ThisWorkbook.Path & Application.PathSeparator
strFile = Dir(strPath & "*.xls")
Application.ScreenUpdating = False
On Error GoTo errorhandle
Do While Len(strFile)
If strFile <> ThisWorkbook.Name And strFile Like "*.xls" Then
'找到文件后执行的操作
Set wb = GetObject(strPath & strFile)
With wb
If SheetIsExist(wb, strSheet) Then
strNewSheet = Replace(strFile, ".xls", "")
If Not SheetIsExist(ThisWorkbook, strNewSheet) Then
Worksheets.Add after:=Worksheets(Worksheets.Count)
ActiveSheet.Name = strNewSheet
End If
.Worksheets(strSheet).UsedRange.Copy Worksheets(strNewSheet).Range("a1")
Else
strMsg = strMsg & "工作簿 " & strFile & " 内没有工作表 " & strSheet & vbCr
End If
Windows(.Name).Visible = True
.Close False
End With
End If
strFile = Dir
Loop
Application.ScreenUpdating = True
If Len(strMsg) = 0 Then strMsg = "汇总完成"
MsgBox strMsg
Exit Sub
errorhandle:
If MsgBox("错误代码：" & Err.Number & vbCr & _
"错误描述：" & Err.Description & vbCr & vbCr & _
"忽略错误，点击是，结束点击否", vbYesNo + vbDefaultButton1, "出错了") = vbYes Then
strMsg = strMsg & "工作表 " & strNewSheet & " 复制出错 " & vbCr
Resume Next
Else
On Error Resume Next
wb.Close False
Application.ScreenUpdating = True
End If
End Sub
Function SheetIsExist(wb As Workbook, index)
On Error Resume Next
SheetIsExist = Len(wb.Worksheets(index).Name) > 0
End Function

复制代码

hwc2ycy · 发表于 2014-3-1 10:30

进度在状态栏显示，显示改进下。

Option Explicit
Sub test()
Dim strPath As String, strFile As String
Dim wb As Workbook
Dim strSheet$
Dim strNewSheet$
Dim strMsg$
strSheet = "月度考勤簿"
strPath = ThisWorkbook.Path & Application.PathSeparator
strFile = Dir(strPath & "*.xls")
Application.ScreenUpdating = False
On Error GoTo errorhandle
Do While Len(strFile)
If strFile <> ThisWorkbook.Name And strFile Like "*.xls" Then
'找到文件后执行的操作
Set wb = GetObject(strPath & strFile)
With wb
If SheetIsExist(wb, strSheet) Then
strNewSheet = Replace(strFile, ".xls", "")
If Not SheetIsExist(ThisWorkbook, strNewSheet) Then
Worksheets.Add after:=Worksheets(Worksheets.Count)
ActiveSheet.Name = strNewSheet
End If
Application.StatusBar = "正在处理工作簿　" & strPath & strFile
.Worksheets(strSheet).UsedRange.Copy Worksheets(strNewSheet).Range("a1")
Else
strMsg = strMsg & " 工作簿 " & strFile & " 内没有工作表 " & strSheet & vbCr
End If
Windows(.Name).Visible = True
.Close False
End With
End If
strFile = Dir
Loop
Worksheets("汇总").Activate
Application.ScreenUpdating = True
If Len(strMsg) = 0 Then
strMsg = "汇总完成"
Else
strMsg = "汇总完成" & vbCr & "出错情况如下：" & vbCr & strMsg
End If
Application.StatusBar = False
MsgBox strMsg, vbInformation
Exit Sub
errorhandle:
If MsgBox("错误代码：" & Err.Number & vbCr & _
"错误描述：" & Err.Description & vbCr & vbCr & _
"忽略错误，点击是，结束点击否", vbYesNo + vbDefaultButton1 + vbCritical, "出错了") = vbYes Then
strMsg = strMsg & " " & strNewSheet & " 复制出错" & vbCr
Resume Next
Else
On Error Resume Next
wb.Close False
Application.ScreenUpdating = True
End If
End Sub
Function SheetIsExist(wb As Workbook, index)
On Error Resume Next
SheetIsExist = Len(wb.Worksheets(index).Name) > 0
End Function

复制代码

icenotcool · 发表于 2014-3-1 10:49

老师，在我原文件上改，好吗？提示出错啊

hwc2ycy · 发表于 2014-3-1 11:00

你把代码放在汇总表里执行就成了。

hwc2ycy · 发表于 2014-3-1 11:01

这个最佳答案由 hwc2ycy 给出，感谢 hwc2ycy 的回答。

单击隐藏图章

汇总.rar (19.65 KB, 下载次数: 14)

icenotcool · 发表于 2014-3-1 11:51

老师，我想加2句进去该放哪里呢？
.Sheets(st).[a1].PasteSpecial Paste:=xlPasteFormats
.Sheets(st).[a1].PasteSpecial Paste:=xlPasteColumnWidths，还有复制后不想要那2个按钮及公式，及有效性存在，但是保留原有报表结构一样

hwc2ycy · 发表于 2014-3-2 16:15

icenotcool 发表于 2014-3-1 11:51
老师，我想加2句进去该放哪里呢？
.Sheets(st).[a1].PasteSpecial Paste:=xlPasteFormats
.Sheets(st ...

按钮复制过来了？我好像是复制的单元格，不是工作表。

如果你要复制格式，就在相对应的位置操作。

要删除按钮，可遍历工作表的shapes集合，根据类型判断。

icenotcool · 发表于 2014-3-2 18:34

老师，我只要数值形式内容复制过来，还含有格式，老师可以帮我再修改一下，好吗？

		自动登录	找回密码
密码			注册