不打开工作簿提取数据

yanglinzi

贵在参与。。

小NN

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

大神，你看我改了下：
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 = "G:\文件夹\" '根据需要修改路径
    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("Z16,AZ49,ZH51")
                    cellContents = cell.Value
                    targetSheet.Cells(targetRow, x).Value = cellContents
                    x = x + 1
                Next cell
                targetSheet.Cells(targetRow, 4).Value = wb.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
改了这句： For Each cell In ws.Range("Z16,AZ49,ZH51")
这句提示下标越界：Set targetSheet = ThisWorkbook.Worksheets("sheet1")

cai2532

学习留下脚印。

fzxba

1.   Dim strPath As String
   
2. '  With Application.FileDialog(msoFileDialogFolderPicker)
   
3. '    .InitialFileName = ThisWorkbook.Path
   
4. '    If .Show Then strPath = .SelectedItems(1) Else: Exit Sub
   
5. '  End With
   
6. '  If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
   
7.   strPath = ThisWorkbook.Path & "\文件夹\"
   
8.   
   
9.   Dim Conn As Object, Cata As Object, tb As Object
   
10.   Dim strConn As String, strFile As String, t As String, i As Long
    
11.   
    
12.   Sheet1.Activate
    
13.   ActiveSheet.UsedRange.Offset(1).ClearContents
    
14.   
    
15.   Application.ScreenUpdating = False
    
16.   
    
17.   Set Conn = CreateObject("ADODB.Connection")
    
18.   Set Cata = CreateObject("ADOX.Catalog")
    
19.   
    
20.   If Application.Version < 12 Then
    
21.     strConn = "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties='Excel 8.0;HDR=NO';Data Source="
    
22.   Else
    
23.     strConn = "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties='Excel 12.0;HDR=NO';Data Source="
    
24.   End If
    
25.   'Conn.Open strConn & ThisWorkbook.FullName
    
26.   
    
27.   On Error Resume Next   '数据不规范，无奈之举，用上容错……
    
28.   strFile = Dir(strPath & "*.xls*")
    
29.   While Len(strFile)
    
30.     If strPath & strFile <> ThisWorkbook.FullName Then
    
31.       Conn.Open strConn & strPath & strFile
    
32.       Cata.ActiveConnection = Conn
    
33.       For Each tb In Cata.Tables
    
34.         If tb.Type = "TABLE" Then
    
35.           t = Replace(tb.Name, "'", vbNullString)
    
36.           If Right(t, 1) = "$" Then
    
37.             i = i + 1
    
38.             With Range("A1")
    
39.               .Offset(i, 0).CopyFromRecordset Conn.Execute("SELECT * FROM [" & t & "D10:D10]")
    
40.               .Offset(i, 1).CopyFromRecordset Conn.Execute("SELECT * FROM [大大]")
    
41.               .Offset(i, 2).CopyFromRecordset Conn.Execute("SELECT * FROM [小小]")
    
42.               .Offset(i, 3) = Split(strFile, ".xls")(0)
    
43.               .Offset(i, 4) = Left(t, Len(t) - 1)
    
44.             End With
    
45.           End If
    
46.           If Err.Number Then Err.Clear
    
47.         End If
    
48.       Next
    
49.       If Conn.State = 1 Then Conn.Close
    
50.     End If
    
51.     strFile = Dir
    
52.   Wend
    
53.   
    
54.   Set Cata = Nothing
    
55.   Set Conn = Nothing
    
56.   
    
57.   Application.ScreenUpdating = True
    
58.   Beep
    
59. End Sub

复制代码