父表与相关联的子表合并成一份Excel表

cqmmygtb11

以前的做法是将数据记录在一个Excel表格中，其中总账作为明细总账，并为每个产品名称创建子表，然后通过超链接将这些子表链接到总账中。随着时间的推移，子表数量增加至近10万个，导致在打开总账时，系统读取这些子表变得非常缓慢。如果最初将这些产品明细以“工作表”的形式在父表中创建，打开父表的响应速度会显著提高。
那如何用VBA代码把已创建的父表（父表名称1.xlsm） 相关联的子表(通过超链接打开，存放路径：B:\ww\）合并成一份xlsm表，合并后各表的工作表保持独立（不合并成一份工作表）且合并完成后删除源文件后超链接 公式不会失效？
未合并前，父表是总账，有且只有一个工作表（名称Sheet1），子表也是有且只有一个工作表（名称Sheet1）.我们需要更加精确地处理超链接更新。我们需要移除旧的超链接，然后在同一个单元格中添加新的超链接。还有复制子表到父表后工作表名称也相应改为子表文件名称，比如子表文件名为A.xlsx，那相应工作表名称也改为A

cqmmygtb11

不管最后有没有帮上忙，都要谢谢你们

ykcbf1100

最重要的是，你要先上个附件，没有附件谁来了也帮不了你。

tanglf188

看你表格是否规范，规范的话用ADO因该比较快的，既然用VBA了，公式最好舍弃，那是卡顿的根源

cqmmygtb11

ykcbf1100 发表于 2024-6-13 15:31
最重要的是，你要先上个附件，没有附件谁来了也帮不了你。

见附档！

cqmmygtb11

tanglf188 发表于 2024-6-13 15:45
看你表格是否规范，规范的话用ADO因该比较快的，既然用VBA了，公式最好舍弃，那是卡顿的根源

哦哦，还有这么一回事啊，谢谢，长见识了。

关于系统卡顿，像当EXCEL细小的文件过多，写入磁盘占用的扇区越分散，越容易产生磁盘碎片，当读取小文件，磁盘磁头不断的寻道；小文件过多也会占用大量文件表项资源，使文件系统管理效率降低，当系统需要不断读取细小文件使，系统就会表现得很卡

cqmmygtb11

关于系统卡顿，像当EXCEL细小的文件过多，写入磁盘占用的扇区越分散，越容易产生磁盘碎片，当读取小文件，磁盘磁头不断的寻道；小文件过多也会占用大量文件表项资源，使文件系统管理效率降低，当系统需要不断读取细小文件时，系统就会表现得很卡

tanglf188

cqmmygtb11 发表于 2024-6-13 16:42
见附档！

没数据啊，怎么弄来着？

cqmmygtb11

我查看下附档，有EXCEL文件（数据），
不知道我所理解的数据跟你所说的是不是一样

3190496160

Sub 拷贝()
Application.ScreenUpdating = False
Dim arr()
Dim sh As Worksheet
Dim ww As Workbook
Dim fs As Object
Set fs = CreateObject("Scripting.FileSystemObject")
lj = ThisWorkbook.Path
Set f = fs.getfolder(lj)
For Each fd In f.subfolders
    n = n + 1
    ReDim Preserve arr(1 To n)
    arr(n) = fd.Name
Next
Set f = Nothing
Set fs = Nothing
Application.DisplayAlerts = False
For Each sh In Sheets
    If sh.Index > 1 Then
        sh.Delete
    End If
Next sh
Application.DisplayAlerts = True
Set ww = ThisWorkbook
For i = 1 To n
    f = Dir(lj & "\" & arr(i) & "\*.xls*")
    Do While f <> ""
        If f <> ThisWorkbook.Name Then
            Set wb = Workbooks.Open(lj & "\" & arr(i) & "\" & f, 0)
            mc = Left(wb.Name, Len(wb.Name) - 4)
            wb.Worksheets(1).Copy after:=ww.Sheets(ww.Sheets.Count)
            ww.Sheets(ww.Sheets.Count).Name = mc
            wb.Close False
        End If
    f = Dir
    Loop
    Set f = Nothing
Next i
Application.ScreenUpdating = False
MsgBox "ok!"
End Sub