文件夹内多个文档合并拆分问题。

saiyang2023 · 发表于 2023-4-13 00:32

2个问题：
1、文件夹内多个文档合并到1个文档中。格式如附图，示例数据文件名在第一行，标黄色，然后第二行开始是第一个示例数据内容；然后是第二个文件名，第二个示例数据内容，以此类推。直至所有文件合并结束。
2、生成的汇总表逆向导出多个文件，并以标黄色内容为文件名，文件内容是汇总表中对应文件名下方内容，相当于就是第一个合并的逆向拆分。

应该是2段代码。
新手菜鸟，请各位大佬协助。感激不尽！！！
附件压缩包为三个示例数据文件和一个汇总文件示例，供参考！

chxw68 · 发表于 2023-4-13 09:50

Sub test1() '汇总
Dim r%, i%
Dim arr, brr
Dim wb As Workbook
Dim ws As Worksheet
Dim mypath$, myname$
mypath = ThisWorkbook.Path & ""
myname = Dir(mypath & "*.xls")
Application.ScreenUpdating = False
Application.DisplayAlerts = False
With ThisWorkbook.Worksheets("sheet1")
.Cells.Clear
End With
m = 1
Do While myname <> ""
If myname <> ThisWorkbook.Name Then
Set wb = GetObject(mypath & myname)
With wb
With .Worksheets(1)
r = .Cells(.Rows.Count, 1).End(xlUp).Row
c = .Cells(1, .Columns.Count).End(xlToLeft).Column
ThisWorkbook.Worksheets("sheet1").Cells(m, 1) = Split(myname, ".")(0)
.Range("a1").Resize(r, c).Copy ThisWorkbook.Worksheets("sheet1").Cells(m + 1, 1)
m = m + 1 + r
End With
.Close False
End With
End If
myname = Dir
Loop
End Sub

复制代码

chxw68 · 发表于 2023-4-13 09:56

Sub test2() '拆分
Dim r%, i%, m%
Dim arr, brr, zrr()
Dim wb As Workbook
Dim ws As Worksheet
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.SheetsInNewWorkbook = 1
With ThisWorkbook.Worksheets("sheet1")
r = .UsedRange.Find(what:="*", LookIn:=xlValues, lookat:=xlWhole, searchorder:=xlByRows, searchdirection:=xlPrevious).Row
c = .UsedRange.Find(what:="*", LookIn:=xlValues, lookat:=xlWhole, searchorder:=xlByColumns, searchdirection:=xlPrevious).Column
If r = 1 Then
Exit Sub
End If
arr = .Range("a1").Resize(r, c)
m = 0
For i = 1 To UBound(arr)
If Len(arr(i, 2)) = 0 Then
m = m + 1
ReDim Preserve zrr(1 To m)
zrr(m) = Array(i, i)
Else
If m > 0 Then
zrr(m)(1) = i
End If
End If
Next
For k = 1 To UBound(zrr)
Set wb = Workbooks.Add
With wb
With .Worksheets(1)
ThisWorkbook.Worksheets("sheet1").Cells(zrr(k)(0), 1).Resize(zrr(k)(1) - zrr(k)(0) + 1, c).Copy .Range("a1")
End With
.SaveAs Filename:=ThisWorkbook.Path & "" & arr(zrr(k)(0), 1)
.Close False
End With
Next
End With
End Sub

复制代码

chxw68 · 发表于 2023-4-13 09:57

详见附件。

saiyang2023 · 发表于 2023-4-13 12:38

汇总思路是对的。但内容不全。拆分提示错误。不过也非常感谢大佬了！

杨建营 · 发表于 2023-4-13 12:44

saiyang2023 发表于 2023-4-13 12:38
汇总思路是对的。但内容不全。拆分提示错误。不过也非常感谢大佬了！

你的分表的格式不够一致，第一个表多了一个行，你自己修改下再运行试试。

saiyang2023 · 发表于 2023-4-13 14:29

收到。我再测试一下。非常感谢！！

ykcbf1100 · 发表于 2023-4-13 15:02

saiyang2023 发表于 2023-4-13 12:38
汇总思路是对的。但内容不全。拆分提示错误。不过也非常感谢大佬了！

chxw68老师的拆分代码没有问题，是你的分表不够规范造成。第一个分表中多了一行，造成合并时多了一个无用行。

sunshuangzhong · 发表于 2023-4-13 16:23

With wb
            With .Worksheets(1)
                  ThisWorkbook.Worksheets("sheet1").Cells(zrr(k)(0), 1).Resize(zrr(k)(1) - zrr(k)(0) + 1, c).Copy .Range("a1")
                  Rows(1).Delete '加上这句
            End With
            .SaveAs Filename:=ThisWorkbook.Path & "\" & arr(zrr(k)(0), 1)
            .Close False
         End With

ykcbf1100 · 发表于 2023-4-14 13:56

sunshuangzhong 发表于 2023-4-13 16:23
With wb
With .Worksheets(1)
ThisWorkbook.Worksheets("sheet1"). ...

你不要误导楼主，只有第一个分表中多了一行，其它二个分表是正常的。

应该删分表的数据，代码不用改。

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

[求助] 文件夹内多个文档合并拆分问题。

评分

评分