多个工作薄提取里面相同的工作表名，合并成一个工作表

panjinju

每一个工作薄都有附件1、2、3、4，提取出来全并成一个工作表

panjinju

每个工作薄里的

abc123281

上传你的附件

lsc900707

panjinju 发表于 2019-1-12 12:04
每个工作薄里的

没有附件很难得到满意的解答。

cjc209

Sub 多薄同名表重组为一薄多表()
Dim d As Object, p$, f$, h&, sh As Worksheet, nm$, n As Name
bm = ActiveSheet.Name
btzmh = Val(Application.InputBox("请输入 标题最末行的行号：", "默认值", "1"))
bwh = Val(Application.InputBox("请输入 表尾占据的总行数：", "默认值", "0"))
Application.ScreenUpdating = False
Set d = CreateObject("scripting.dictionary")
p = ThisWorkbook.Path & "\"
f = Dir(p & "*.xls*")
Application.DisplayAlerts = False
Do While f <> ""
    If f <> ThisWorkbook.Name Then
        With Workbooks.Open(p & f)
            For Each sh In .Worksheets
                nm = sh.Name
                If Not d.exists(nm) Then
                    d(nm) = ""
                    sh.Copy after:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
                    h2 = ThisWorkbook.Sheets(nm).UsedRange.Rows.Count + ThisWorkbook.Sheets(nm).UsedRange.Row - 1
                    If bwh > 0 Then
                      ThisWorkbook.Sheets(nm).Rows(h2 - bwh + 1 & ":" & h2).Delete
                    End If
                Else
                    With sh
                        h = sh.UsedRange.Rows.Count + sh.UsedRange.Row - 1 - btzmh - bwh
                        qsl = sh.UsedRange.Column
                        h1 = ThisWorkbook.Sheets(nm).UsedRange.Rows.Count + ThisWorkbook.Sheets(nm).UsedRange.Row
                        .UsedRange.Offset(btzmh).Resize(h).Copy ThisWorkbook.Sheets(nm).Cells(h1, qsl)
                    End With
                End If
            Next
            .Close 0
        End With
    End If
    f = Dir
Loop
On Error Resume Next
For Each n In ThisWorkbook.Namesa
    n.Delete
Next
Err.Clear
Sheets(bm).Delete
Set d = Nothing
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox "提取完毕！"
End Sub

jjmysjg

cjc209 发表于 2019-1-12 12:42
Sub 多薄同名表重组为一薄多表()
Dim d As Object, p$, f$, h&, sh As Worksheet, nm$, n As Name
bm = A ...

代码不能运行

cjc209

jjmysjg 发表于 2019-1-12 20:44
代码不能运行

把你的附件发上来吧