|
|
楼主 |
发表于 2023-6-19 07:19
|
显示全部楼层
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用 · 内置多项VBA编程加强工具 ★ 免费下载 ★ ★ 使用手册★
本帖最后由 OKJSJSF 于 2023-6-22 07:27 编辑
excel通用工具.rar
(690.04 KB, 下载次数: 9)
2023年6月19日通用工具的更新主要是数据工具中修改了同一文件夹中多工作簿的工作表数据合并，改为多簿多表合并，不是只合并各簿中的一个表 。对其中主代码的周边条件判断辅助代码也作了完善。
Sub cb22(control As IRibbonControl) '簿外并表，不使用查询连接可以突破50个表的限制
If Workbooks.Count = 0 Then
MsgBox "没有可操作的工作簿。", vbExclamation, "微软的提醒："
Exit Sub
End If
Dim rstart As Byte, c As Byte, i As Byte, shcount%, ranaddr$, mypath$, wb As Workbook, sh As Worksheet, ran As Range
If MsgBox("本命令用于合并（上下串连）同一文件夹内各工作簿的各工作表的数据。注意：" & Chr(10) & "1、待合并的工作簿须取消保护，工作表须取消筛选。" & Chr(10) & "2、执行前先打开一个待合并分表所在工作簿。" & Chr(10) & "3、程序会在本文件夹内创建一个名称及表名均为“hebin”的工作簿，用于存放合并数据。如果已有它，程序会先删除它并新建。" & Chr(10) & "4、各分表须结构相同，列标题左右连续，数据中间无全空行（至少某列数据须上下连续），列标题上行、数据区域下行及右边列三面全是空格。" & Chr(10) & "5、各表数据区域列标题的上部的大小标题与台头、及表格下部各种填表注释说明，可在合并后手工粘贴。" & Chr(10) & "" & Chr(10) & "如果不用本功能或想全手工操作，请单击“取消”或“X”。", vbOKCancel + vbInformation, "功能说明：") <> vbOK Then Exit Sub
mypath = ActiveWorkbook.Path '确定文件夹位置
If Len(Dir(mypath & "\hebin.xlsx")) > 0 Then '如果指定文件存在就删除它
For i = 1 To Workbooks.Count
If Workbooks(i).Name = "hebin.xlsx" Then '如果打开的文件中有指定文件，必须先关闭它，才能删除
Workbooks(i).Close False
Exit For
End If
Next
If MsgBox("程序在删除名称为 hebin 的工作簿。如该簿无重要数据，可单击“确定”或回车，执行删除。或单击“取消”或“X”，不删除并退出程序。", vbOKCancel + vbExclamation, "微软的提醒：") <> vbOK Then Exit Sub
If MsgBox("程序在删除名称为 hebin 的工作簿。如该簿有重要数据未另存，可单击“取消”或“X”，不删除并退出程序。或单击“确定”或回车，执行删除。", vbOKCancel + vbExclamation, "微软的提醒第二遍：") <> vbOK Then Exit Sub
Kill mypath & "\hebin.xlsx"
End If
If Workbooks.Count = 0 Then
MsgBox "请重新打开一个工作簿再执行。", , "微软的提醒："
Exit Sub
End If
On Error GoTo errline
Set ran = Application.InputBox("请在待合并分表单击选择【列标题】第一个单元格：", "参数设置", , , , , , 8)
t = Timer
ranaddr = ran.Address
c = ran.CurrentRegion.Columns.Count
Application.ScreenUpdating = False
Call stabar '这是启用状态栏提示文字：程序运行中，请稍候，请 稍 候，，，，，，
Set wb = Workbooks.Add
Set sh = wb.Worksheets(1)
With sh
.Name = "hebin"
ran.Resize(1, c).Copy .Cells(1)
.Cells(1, c + 1).Value = "表名"
.Cells(1, c + 2).Value = "簿名"
End With
wb.SaveAs mypath & "\hebin.xlsx"
Dim filename As String, fn As String, r As Long, rtemp As Long
filename = Dir(mypath & "\*.xlsx")
Application.EnableEvents = False
Do While filename <> ""
If filename <> "hebin.xlsx" Then
i = i + 1
fn = mypath & "\" & filename
Set wb = GetObject(fn)
If wb.ProtectStructure = True Then
If MsgBox(wb.Name & "工作簿被保护，请单击“确定”或回车，进入下一步撤销保护。或单击“取消”或“X”，不撤销保护并退出程序。", vbOKCancel + vbExclamation, "微软的提醒：") <> vbOK Then
Exit Sub
Else
wb.Unprotect
End If
End If
For Each sh In wb.Worksheets
With sh
If .FilterMode = True Then
If .ProtectContents = True Then
If MsgBox(wb.Name & "工作簿的" & .Name & "工作表 被保护，请单击“确定”或回车，进入下一步撤销保护。或单击“取消”或“X”，不撤销保护并退出程序。", vbOKCancel + vbExclamation, "微软的提醒：") <> vbOK Then
Exit Sub
Else
.Unprotect
End If
End If
.ShowAllData '被筛选掉的数据无法被复制，被设置隐藏或行高为0的数据则可以被复制,工作表被保护或隐藏或深度隐藏也可复制
End If
r = .Range(ranaddr).CurrentRegion.Rows.Count - 1
.Range(ranaddr).Offset(1, 0).Resize(r, c).Copy
On Error Resume Next
With Cells(rtemp + 2, 1)
.PasteSpecial xlPasteAllUsingSourceTheme
.PasteSpecial xlPasteValues
.Offset(0, c).Resize(r, 1).Value = sh.Name
.Offset(0, c + 1).Resize(r, 1).Value = wb.Name
End With
Application.CutCopyMode = xlCut
rtemp = rtemp + r
End With
Next
wb.Close False
End If
filename = Dir
Loop
Range("a2").Select
ActiveWindow.FreezePanes = True
Application.EnableEvents = True
Application.ScreenUpdating = True
MsgBox "多簿表合并完毕，耗时" & Format(Timer - t, "0.00") & "秒。数据共" & rtemp & "行。" & Chr(10) & "1、如有各分表行序号并入造成重复，可重新填充。" & Chr(10) & "2、如有各分表表尾信息并入造成重复，可采用局部查找后全选后删除行。"
Set ran = Nothing
Set wb = Nothing
Set sh = Nothing
Exit Sub
errline: MsgBox Err.Description
End Sub
|
|
楼主: OKJSJSF
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2023-6-19 11:19