只差最后一步了，我以后可以不用通宵了，帮帮我吧

翁知江安

楼主,可以考虑建立超链接,显示不显示公式意义不是很大

opiona

如果只要数值, 不要公式 可以看看:
https://club.excelhome.net/thread-1409141-1-1.html

qdchyq

Sub ExtractDataFromMultipleXLS()
    Dim fileDialog As fileDialog
    Dim filePath As Variant
    Dim wb As Workbook
    Dim ws As Worksheet
    Dim targetWs As Worksheet
    Dim dataRange As Range
    Dim colOffset As Integer
    Dim fileName As String
    Dim sheetName As String
    Dim foundSheet As Boolean
   
    ' 设置目标工作表为当前活动工作表
    Set targetWs = ActiveSheet
    colOffset = 0
   
    ' 获取要提取的工作表名
    sheetName = InputBox("请输入要提取数据的工作表名", "输入工作表名")
    If sheetName = "" Then
        MsgBox "未输入有效的工作表名，操作取消。"
        Exit Sub
    End If
   
    ' 将输入的工作表名转换为大写
    sheetName = UCase(sheetName)
   
    ' 创建文件选择对话框
    Set fileDialog = Application.fileDialog(msoFileDialogFilePicker)
    With fileDialog
        .Title = "选择 XLS 文件"
        .Filters.Clear
        .Filters.Add "Excel 文件", "*.xls*"
        .AllowMultiSelect = True
        
        ' 显示文件选择对话框
        If .Show = -1 Then
            ' 遍历所选的每个文件
            For Each filePath In .SelectedItems
                ' 打开所选的工作簿
                Set wb = Workbooks.Open(filePath)
                ' 获取工作簿名（不含扩展名）
                fileName = Left(wb.Name, InStrRev(wb.Name, ".") - 1)
               
                foundSheet = False
                ' 遍历工作簿中的所有工作表
                For Each ws In wb.Sheets
                    ' 将当前工作表名转换为大写并比较
                    If UCase(ws.Name) = sheetName Then
                        ' 设置要复制的数据范围
                        Set dataRange = ws.Range("C3:C40")
                        
                        ' 在目标工作表中复制数据
                        dataRange.Copy targetWs.Cells(3, 3 + colOffset)
                        
                        ' 在目标工作表的第一行写入工作表名
                        targetWs.Cells(1, 3 + colOffset).Value = ws.Name
                        ' 在目标工作表的第二行写入文件名
                        targetWs.Cells(2, 3 + colOffset).Value = fileName
                        
                        ' 列偏移量增加，以便下一个工作表的数据放在下一列
                        colOffset = colOffset + dataRange.Columns.Count
                        foundSheet = True
                        Exit For
                    End If
                Next ws
               
                If Not foundSheet Then
                    MsgBox "在文件 " & wb.Name & " 中未找到名为 " & sheetName & " 的工作表。", vbExclamation
                End If
               
                ' 关闭打开的工作簿，不保存更改
                wb.Close SaveChanges:=False
            Next filePath
        End If
    End With
End Sub

qdchyq

你看看能不能满足

313667354

楼主09年发的贴，估计现在用不上了，沉太久了。

jjmysjg

qdchyq 发表于 2025-4-7 16:14
你看看能不能满足

数据源B3向下的名称，能自动提取各源表不重复的到汇总表、然后在合并C列吗

qdchyq

jjmysjg 发表于 2025-4-7 21:28
数据源B3向下的名称，能自动提取各源表不重复的到汇总表、然后在合并C列吗

Sub ExtractAndSumData2222()
    Dim folderPath As String
    Dim fileName As String
    Dim summaryWb As Workbook
    Dim summaryWs As Worksheet
    Dim sourceWb As Workbook
    Dim sourceWs As Worksheet
    Dim i As Long, j As Long, col As Long
    Dim matchValue As Variant
    Dim tempDict As Object
    Dim allNamesDict As Object
    Dim key As Variant
    Dim rowCount As Long
   
    ' 设置汇总表工作簿和工作表
    Set summaryWb = ThisWorkbook
    Set summaryWs = summaryWb.ActiveSheet
   
    ' 选择文件夹
    With Application.fileDialog(msoFileDialogFolderPicker)
        .Title = "选择包含 Excel 文件的文件夹"
        If .Show = -1 Then
            folderPath = .SelectedItems(1)
        Else
            MsgBox "未选择文件夹，操作取消。"
            Exit Sub
        End If
    End With
   
    ' 添加文件夹路径分隔符
    If Right(folderPath, 1) <> "\" Then
        folderPath = folderPath & "\"
    End If
   
    ' 创建一个字典用于存储所有出现过的名称
    Set allNamesDict = CreateObject("Scripting.Dictionary")
   
    ' 获取文件夹中的第一个 Excel 文件
    fileName = Dir(folderPath & "*.xls*")
   
    ' 遍历文件夹中的所有 Excel 文件
    Do While fileName <> ""
        ' 排除汇总工作簿
        If fileName <> summaryWb.Name Then
            ' 打开工作簿
            Set sourceWb = Workbooks.Open(folderPath & fileName)
            
            ' 遍历工作簿中的所有工作表
            For Each sourceWs In sourceWb.Sheets
                ' 遍历当前工作表 B3:B38 区域
                For j = 3 To 38
                    matchValue = sourceWs.Cells(j, 2).Value
                    If matchValue <> "" And Not allNamesDict.Exists(matchValue) Then
                        allNamesDict.Add matchValue, 1
                    End If
                Next j
            Next sourceWs
            
            ' 关闭工作簿，不保存更改
            sourceWb.Close SaveChanges:=False
        End If
        ' 获取下一个 Excel 文件
        fileName = Dir
    Loop
   
    ' 将所有不重复的名称写入汇总表 B3:B38
    rowCount = 3
    For Each key In allNamesDict.Keys
        summaryWs.Cells(rowCount, 2).Value = key
        rowCount = rowCount + 1
        If rowCount > 38 Then Exit For
    Next key
   
    col = 3 ' 从 C 列开始写入数据
    fileName = Dir(folderPath & "*.xls*") ' 重新开始遍历文件
   
    ' 再次遍历文件夹中的所有 Excel 文件进行求和操作
    Do While fileName <> ""
        ' 排除汇总工作簿
        If fileName <> summaryWb.Name Then
            ' 打开工作簿
            Set sourceWb = Workbooks.Open(folderPath & fileName)
            
            ' 创建一个字典用于存储每个名称对应的总和
            Set tempDict = CreateObject("Scripting.Dictionary")
            
            ' 遍历工作簿中的所有工作表
            For Each sourceWs In sourceWb.Sheets
                ' 遍历当前工作表 B3:B38 区域
                For j = 3 To 40
                    matchValue = sourceWs.Cells(j, 2).Value
                    If Not tempDict.Exists(matchValue) Then
                        tempDict.Add matchValue, sourceWs.Cells(j, 3).Value
                    Else
                        tempDict(matchValue) = tempDict(matchValue) + sourceWs.Cells(j, 3).Value
                    End If
                Next j
            Next sourceWs
            
            ' 将汇总值写入汇总表对应列
            For i = 3 To 40
                matchValue = summaryWs.Cells(i, 2).Value
                If tempDict.Exists(matchValue) Then
                    summaryWs.Cells(i, col).Value = tempDict(matchValue)
                End If
            Next i
            
            ' 写入文件名到第二行
            summaryWs.Cells(2, col).Value = Replace(fileName, ".xlsx", "")
            summaryWs.Cells(2, col).Value = Replace(summaryWs.Cells(2, col).Value, ".xls", "")
            
            col = col + 1 ' 移动到下一列
            
            ' 关闭工作簿，不保存更改
            sourceWb.Close SaveChanges:=False
        End If
        ' 获取下一个 Excel 文件
        fileName = Dir
    Loop
End Sub
   

jjmysjg

qdchyq 发表于 2025-4-9 20:19
jjmysjg 发表于 2025-4-7 21:28
数据源B3向下的名称，能自动提取各源表不重复的到汇总表、然后在合并C列吗 ...

谢谢大侠！
数据源的B列修改名，汇总名称没有变化。
要求：提取数据源B3向下的不重复名称到汇总表

313667354

参与下，请测试，不需要提前在标题行写上工作簿的名称，代码自动完成。

jjmysjg

313667354 发表于 2025-4-10 15:04
参与下，请测试，不需要提前在标题行写上工作簿的名称，代码自动完成。

汇总表B列的名称，能自动从数据源筛选进来吗