新人求助！！关于工作簿合并的问题，求大佬看看

cjc209

7楼的就是正确的

lies0101

xiangbaoan 发表于 2018-10-3 17:31
……仅供参考、测试……

谢谢大佬！和我想要的效果差不多，还有个小小的要求不知道能不能满足下，就是在箭头的位置能不能加上另一个工作簿的编号和名称。

cjc209

只不过你的表格变动的时候 相关的代码就要改动 比如标题行的增减情况 他没有做成变量让你自己做出选择

cjc209

你把代码你的6改成5就有了

cjc209

他把那个作为了标题 改成5就作为了提取的数据

cjc209

lies0101 发表于 2018-10-3 19:50
谢谢大佬！和我想要的效果差不多，还有个小小的要求不知道能不能满足下，就是在箭头的位置能不能加上另 ...

你是VBA 一窍不通吗？

xiangbaoan

[quote]lies0101 发表于 2018-10-3 19:50
谢谢大佬！和我想要的效果差不多，还有个小小的要求不知道能不能满足下，就是在箭
………………

xiangbaoan

cjc209 大侠说的对，把 2 处 6 改成 5，总算明白了你的意思
   h = .[b65536].End(xlUp).Row - 5
  .UsedRange.Offset(5).Resize(h).Copy ThisWorkbook.Sheets(nm).[b65536].End(xlUp).Offset(1, -1)

jjmysjg

留下记号，谢谢

cjc209

xiangbaoan 发表于 2018-10-3 20:41
cjc209 大侠说的对，把 2 处 6 改成 5，总算明白了你的意思
   h = ..End(xlUp) ...

像这种 你把标题行号引用为对话款形式就可以成这一类型的通用工具了多好 用时只需运行输入标题行的最末行号就ok了  再做一下小修改比如这样

1. Sub 多薄同名表重组为一薄多表()
   
2. Dim d As Object, p$, f$, h&, sh As Worksheet, nm$, n As Name
   
3. bm = ActiveSheet.Name
   
4. btzmh = Val(Application.InputBox("请输入 标题最末行的行号："))
   
5. Application.ScreenUpdating = False
   
6. Set d = CreateObject("scripting.dictionary")
   
7. p = ThisWorkbook.Path & ""
   
8. f = Dir(p & "*.xls*")
   
9. Application.DisplayAlerts = False
   
10. Do While f <> ""
    
11.     If f <> ThisWorkbook.Name Then
    
12.         With Workbooks.Open(p & f)
    
13.             For Each sh In .Worksheets
    
14.                 nm = sh.Name
    
15.                 If Not d.exists(nm) Then
    
16.                     d(nm) = ""
    
17.                     sh.Copy after:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
    
18.                 Else
    
19.                     With sh
    
20.                         h = .[b65536].End(xlUp).Row - btzmh
    
21.                         .UsedRange.Offset(btzmh).Resize(h).Copy ThisWorkbook.Sheets(nm).[b65536].End(xlUp).Offset(1, -1)
    
22.                     End With
    
23.                 End If
    
24.             Next
    
25.             .Close 0
    
26.         End With
    
27.     End If
    
28.     f = Dir
    
29. Loop
    
30. On Error Resume Next
    
31. For Each n In ThisWorkbook.Names
    
32.     n.Delete
    
33. Next
    
34. Err.Clear
    
35. Sheets(bm).Delete
    
36. Set d = Nothing
    
37. Application.DisplayAlerts = True
    
38. Application.ScreenUpdating = True
    
39. MsgBox "提取完毕！"
    
40. End Sub
    

复制代码