汇总多簿的工作表最后一行的数据并加上去源簿的链接

weide_yang

当前文件夹中有N个只有单表的工作簿，想用代码把每个工作簿的表的最后一行数据提取到汇总工作簿的当前工作表中，并在每行的S列单元格中写入源工作簿的名称且可链接到该源工作簿，请老师赐教，谢谢！

新建文件夹.zip (49.02 KB, 下载次数: 6)

2024-9-5 17:54 上传

点击文件名下载附件

小凡、、、

quqiyuan

参与一下。。。仅供参考。。。

quqiyuan

代码如下。。。
Sub test()
    Application.ScreenUpdating = False
    Set wb = ThisWorkbook
    p = wb.Path & "\"
    Set sht = wb.Sheets("sheet1")
    sht.UsedRange.Offset(3).ClearContents
    f = Dir(p & "*.xls*")
    Do While f <> ""
        If f <> wb.Name Then
            With Workbooks.Open(p & f, 0).Sheets("sheet1")
                r = sht.Cells(sht.Rows.Count, "a").End(3).Row + 1
                rr = .Cells(.Rows.Count, "a").End(3).Row
                Intersect(.Rows(rr), .UsedRange).Copy sht.Cells(r, 1)
                S = Split(.Parent.Name, ".xls")(0)
                sht.Cells(r, "s") = S
                .Hyperlinks.Add anchor:=sht.Cells(r, "s"), Address:=p & f, TextToDisplay:=S
                .Parent.Close 0
            End With
        End If
        f = Dir
    Loop
    Application.ScreenUpdating = True
    Beep
End Sub

limonet

Sub limonet()
    Dim Cn As Object, StrSQL$, i%
    i = 3
    Set Cn = CreateObject("Adodb.Connection")
    Cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source=" & ThisWorkbook.FullName
    Path = ThisWorkbook.Path & "\"
    Filename = Dir(Path & "*.xlsm")
    Do While Filename <> ""
        If Filename <> "汇总.xlsm" Then
            i = i + 1
            Cells(i, "S").Hyperlinks.Add Anchor:=Cells(i, "S"), Address:=Path & Filename, TextToDisplay:=Split(Filename, ".xls")(0)
            StrSQL = StrSQL & " Union All Select * From [Excel 12.0;Database=" & Path & Filename & "].[Sheet1$A3:R] Where 出库_入库='金额列的合计数'"
        End If
        Filename = Dir
    Loop
    Range("A4").CopyFromRecordset Cn.Execute(Mid(StrSQL, 12))
End Sub

limonet

关键字：union all

Qs18

1. Sub qs()
   
2.     Application.ScreenUpdating = False
   
3.     Dim arr, i, wb As Workbook, xb As Workbook
   
4.         Dim FileName
   
5.     Set wb = ThisWorkbook
   
6.     FileName = Application.GetOpenFilename(FileFilter:="Excel 工作簿文件 (*.xls*),*.xls*", Title:="请选择文件", MultiSelect:=True)
   
7.     If Not IsArray(FileName) Then
   
8.         MsgBox "没有选择文件"
   
9.         Exit Sub
   
10.     End If
    
11.     For Each f In FileName
    
12.         Set xb = Workbooks.Open(f, 0)
    
13.         rw = xb.Sheets(1).Cells(Rows.Count, "d").End(3).Row
    
14.         r = wb.Sheets(1).Cells(Rows.Count, 1).End(3).Row + 1
    
15.         xb.Sheets(1).Range("a" & rw & ":r" & rw).Copy wb.Sheets(1).Range("a" & r)
    
16.         x = Mid(f, VBA.InStrRev(f, "") + 1)
    
17.      wb.Sheets(1).Hyperlinks.Add wb.Sheets(1).Range("s" & r), f, , , x
    
18.         xb.Close (0)
    
19.     Next f
    
20.     Application.ScreenUpdating = True
    
21. End Sub

复制代码

Qs18

试试.................

Qs18

试试............