不打开工作簿提取数据

小NN

请教各位，如何不打开文件夹中的工作簿，将每个工作簿（遍历文件夹中所有工作簿的所有表单）中所有相关单元格（D10、E28、G32）的内容提取出来，并标注工作簿名和表单名，列表写在VBA程序所在的工作簿中。

根据各位大神回复，我修改了下，遇到一些新的问题：
比如单元格名称是中文的或是字符数变多了，比如ZH5（不是Z5）这样的单元格，好像就不能运行，下标越界。
再上传个中文名称的附件。

wangyuhui7

Sub ExtractCellContents()
    Dim fso As Object
    Dim folderPath As String
    Dim folder As Object
    Dim file As Object
    Dim wb As Workbook
    Dim ws As Worksheet
    Dim targetSheet As Worksheet
    Dim targetRow, x As Long
    Dim cellContents As String
    Set targetSheet = ThisWorkbook.Worksheets("sheet1")
    targetRow = 2
    folderPath = "D:\Desktop\不打开文件，提取单元格内容\不打开文件，提取单元格内容\文件夹\"
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set folder = fso.GetFolder(folderPath)
    For Each file In folder.Files
        If Right(file.Name, 4) = "xlsx" Or Right(file.Name, 3) = "xls" Then
            Set wb = Workbooks.Open(file.Path, ReadOnly:=True)
            For Each ws In wb.Worksheets
                x = 1
                For Each cell In ws.Range("D10,E28,G32")
                    cellContents = cell.Value
                    targetSheet.Cells(targetRow, x).Value = cellContents
                    x = x + 1
                Next cell
                targetSheet.Cells(targetRow, 5).Value = wb.Name
                targetSheet.Cells(targetRow, 4).Value = ws.Name
                targetRow = targetRow + 1
            Next ws
            wb.Close SaveChanges:=False
        End If
    Next file
    Set folder = Nothing
    Set file = Nothing
    Set wb = Nothing
    Set ws = Nothing
    Set fso = Nothing
End Sub

wangyuhui7

Sub ExtractCellContents()
    Dim fso As Object
    Dim folderPath As String
    Dim folder As Object
    Dim file As Object
    Dim wb As Workbook
    Dim ws As Worksheet
    Dim targetSheet As Worksheet
    Dim targetRow, x As Long
    Dim cellContents As String
    Set targetSheet = ThisWorkbook.Worksheets("sheet1")
    targetRow = 2
    folderPath = "D:\Desktop\不打开文件，提取单元格内容\不打开文件，提取单元格内容\文件夹\"
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set folder = fso.GetFolder(folderPath)
    For Each file In folder.Files
        If Right(file.Name, 4) = "xlsx" Or Right(file.Name, 3) = "xls" Then
            Set wb = Workbooks.Open(file.Path, ReadOnly:=True)
            For Each ws In wb.Worksheets
                x = 1
                For Each cell In ws.Range("D10,E28,G32")
                    cellContents = cell.Value
                    targetSheet.Cells(targetRow, x).Value = cellContents
                    x = x + 1
                Next cell
                targetSheet.Cells(targetRow, 5).Value = wb.Name
                targetSheet.Cells(targetRow, 4).Value = ws.Name
                targetRow = targetRow + 1
            Next ws
            wb.Close SaveChanges:=False
        End If
    Next file
    Set folder = Nothing
    Set file = Nothing
    Set wb = Nothing
    Set ws = Nothing
    Set fso = Nothing
End Sub

小NN

wangyuhui7 发表于 2024-3-14 17:06
Sub ExtractCellContents()
    Dim fso As Object
    Dim folderPath As String

大神，以下是我搜到的其它代码，他多个功能，就是运行这个提取程序后，自动弹窗让选择需要提取的文件夹路径，能否帮忙加到你的代码中，感谢~

Sub 批量复制()
    Dim strFolder$, intRowCnt%, wbTarget As Workbook
    Dim intRowEnd%, intRowPaste%
    Dim intRowsCnt%
    Dim ExcelFile$
   
    Application.ScreenUpdating = False
    intRowPaste = 1
    strFolder = GetPath()
    If strFolder <> "" Then
    ExcelFile = Dir(strFolder & "\*.xls*")
   
        Do Until ExcelFile = ""
            Set wbTarget = Workbooks.Open(strFolder & "\" & ExcelFile)
            intRowsCnt = wbTarget.Sheets(1).[E65535].End(xlUp).Row
            wbTarget.Sheets(1).Range("D1:E" & intRowsCnt).Copy ThisWorkbook.Sheets(1).Cells(intRowPaste, "A")
            intRowPaste = intRowPaste + intRowsCnt
            wbTarget.Close False
            ExcelFile = Dir
        Loop
    End If
    Application.ScreenUpdating = True
End Sub
   
Private Function GetPath() As String
    Set objShell = CreateObject("Shell.Application")
    Set objFolder = objShell.BrowseForFolder(0, "选择文件夹", 0, 0)
    If Not objFolder Is Nothing Then
        GetPath = objFolder.self.Path
    Else
        GetPath = ""
    End If
    Set objFolder = Nothing
    Set objShell = Nothing
End Function
Sub 批量复制_不打开工作簿()
    Dim strFolder$, intRowCnt%, wbTarget As Workbook
    Dim intRowEnd%, intRowPaste%
    Dim intRowsCnt%
    Dim ExcelFile$
   
    Application.ScreenUpdating = False
    intRowPaste = 1
    strFolder = GetPath()
    If strFolder <> "" Then
        ExcelFile = Dir(strFolder & "\*.xls*")
        
        With ThisWorkbook.Sheets(1)
            Do Until ExcelFile = ""
                intRowEnd = 1
                Do
                    .Cells(intRowPaste, "A").Formula = "='" & strFolder & "\[" & ExcelFile & "]Sheet1'!$D" & intRowEnd
                    .Cells(intRowPaste, "B").Formula = "='" & strFolder & "\[" & ExcelFile & "]Sheet1'!$E" & intRowEnd
                    If .Cells(intRowPaste, "A") <> 0 Or .Cells(intRowPaste, "B") <> 0 Then
                        .Cells(intRowPaste, "A") = .Cells(intRowPaste, "A").Value
                        .Cells(intRowPaste, "B") = .Cells(intRowPaste, "B").Value
                        .Cells(intRowPaste, "C") = "来自：" & strFolder & "\" & ExcelFile
                        intRowPaste = intRowPaste + 1
                        intRowEnd = intRowEnd + 1
                    Else
                        Exit Do
                    End If
                Loop
                ExcelFile = Dir
            Loop
        End With
    End If
    Application.ScreenUpdating = True
End Sub

ykcbf1100

附件供参考。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()  '//2024.3.14
   
2.     Set Fso = CreateObject("scripting.filesystemobject")
   
3.     Application.ScreenUpdating = False
   
4.     Set sh = ThisWorkbook.Sheets("Sheet1")
   
5.     ReDim brr(1 To 1000, 1 To 5)
   
6.     p = ThisWorkbook.Path & "\文件夹"
   
7.     For Each f In Fso.GetFolder(p).Files
   
8.         If f.Name Like "*.xls*" Then
   
9.             If InStr(f.Name, ThisWorkbook.Name) = 0 Then
   
10.                 fn = Fso.GetBaseName(f)
    
11.                 m = m + 1
    
12.                 Set wb = Workbooks.Open(f, 0)
    
13.                 With wb.Sheets(1)
    
14.                     brr(m, 1) = .[d10].Value
    
15.                     brr(m, 2) = .[E28].Value
    
16.                     brr(m, 3) = .[G32].Value
    
17.                     brr(m, 4) = fn
    
18.                     brr(m, 5) = .Name
    
19.                     wb.Close False
    
20.                 End With
    
21.             End If
    
22.         End If
    
23.     Next f
    
24.     With sh
    
25.         .[a1].Resize(1, 5).Interior.Color = 49407
    
26.         If m > 0 Then
    
27.             .UsedRange.Offset(1).Clear
    
28.             With .[a2].Resize(m, 5)
    
29.                 .Value = brr
    
30.                 .Borders.LineStyle = 1
    
31.                 .HorizontalAlignment = xlCenter
    
32.                 .VerticalAlignment = xlCenter
    
33.                 .EntireColumn.AutoFit
    
34.             End With
    
35.         End If
    
36.     End With
    
37.     Application.ScreenUpdating = True
    
38.     MsgBox "OK！"
    
39. End Sub
    
40. 
    

复制代码

小NN

wangyuhui7 发表于 2024-3-14 17:06
Sub ExtractCellContents()
    Dim fso As Object
    Dim folderPath As String

大神，请问下
For Each cell In ws.Range("D10,E28,G32")
我有个表格里单元格编号被改成汉字了，我替换这个 语句，运行有问题
改成  For Each cell In ws.Range("D10,单号,页数") 之后只能读取 D10 单号 ，页数 提取不了
改成  For Each cell In ws.Range("单号,页数") 之后只能读取 单号 ，页数 提取不了
不报错，是哪里的问题？

小NN

ykcbf1100 发表于 2024-3-14 19:13
参与一下。。。

大神，这个代码也是和以上问题类似，我有两个单元格是中文名称，就不能用了，怎么修改下？
我改成以下这样，就运行不了了，应该怎么改下？
brr(m, 1) = .[Z15].Value
brr(m, 2) = .[单号].Value
brr(m, 3) = .[页数].Value
还有，我只需要提取数据，不需要画表格线，不知道是改哪里？

wangyuhui7

小NN 发表于 2024-3-14 21:23
大神，请问下
For Each cell In ws.Range("D10,E28,G32")
我有个表格里单元格编号被改成汉字了，我替 ...

这个循环语句是针对你要提取的3个单元格来

小NN

wangyuhui7 发表于 2024-3-14 21:45
这个循环语句是针对你要提取的3个单元格来

我改成中文的单元格名称了，怎么修改程序呀？