Excel 不打开源文件，用VB获取指定文件夹中所有文件内部数据

tyson_zhengsen

在一个Excel中，所有步骤用VB实现，运行VB后：
1、弹出选择文件路径，随机手选D盘中的一个文件夹，例如D:\TEST DATA\，
2、根据选择路径文件夹，获取来自这个文件夹中的所有文件内容；
3、在Excel中，新建一个sheet：
   A列：Folder path（文件夹路径）
   B列：file name    （文件名）
   C列：date modified（修改日期）
   D列：Hyperlink（该文件的超链接）
4、在当前的一个sheet中：
A列A1=获取文件路径
     A2=文件名
     A3。。。A100=提取源文件中A列数据

3190496160

文件系统对象FSO基本可以搞定了，但是 ，不明白你说的第四点是什么意思，也就是，获取的A列的数据，如何呈现在目标表中

3190496160

Sub 提取信息()
Application.ScreenUpdating = False
Dim ar As Variant, br As Variant
Dim i As Long
Dim arr()
Set sht = ThisWorkbook.Worksheets(1)
sht.[a1].CurrentRegion.Offset(1) = Empty
Set fso = CreateObject("Scripting.FileSystemObject")
Set obmapp = CreateObject("Shell.Application").BrowseForFolder(0, "请选择文件目录：", 0, 0)   '选择文件夹对话框
If obmapp Is Nothing Then MsgBox "您没有选择文件夹！": End '如果选择了文件夹
fp = obmapp.Self.Path   '把选择的文件夹的路劲赋值给变量fp
f = Dir(fp & "\*.csv")
ReDim arr(1 To 10000, 1 To 3)
Do While f <> ""
    If f <> ThisWorkbook.Name Then
        n = n + 1
        arr(n, 1) = fp
        arr(n, 2) = f
        Set objfile = fso.GetFile(fp & "\" & f)
        arr(n, 3) = objfile.DateLastModified
        sht.Hyperlinks.Add anchor:=sht.Cells(n + 1, 4), Address:=fp & "\" & f, SubAddress:="", TextToDisplay:=f
    End If
f = Dir
Loop
If n <> "" Then sht.[a2].Resize(n, 3) = arr
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub

3190496160

Sub 提取信息()
Application.ScreenUpdating = False
Dim ar As Variant, br As Variant
Dim i As Long
Dim arr()
Set sht = ThisWorkbook.Worksheets(1)
sht.[a1].CurrentRegion.Offset(1) = Empty
Set fso = CreateObject("Scripting.FileSystemObject")
Set obmapp = CreateObject("Shell.Application").BrowseForFolder(0, "请选择文件目录：", 0, 0)   '选择文件夹对话框
If obmapp Is Nothing Then MsgBox "您没有选择文件夹！": End '如果选择了文件夹
fp = obmapp.Self.Path   '把选择的文件夹的路劲赋值给变量fp
f = Dir(fp & "\*.csv")
ReDim arr(1 To 10000, 1 To 7)
Do While f <> ""
    If f <> ThisWorkbook.Name Then
        n = n + 1
        arr(n, 1) = fp '文件夹路劲
        arr(n, 2) = f '文件名称
        Set objfile = fso.GetFile(fp & "\" & f) '
        arr(n, 3) = objfile.DateLastModified '修改时间
        arr(n, 4) = objfile.DateCreated '文件创建时间
        arr(n, 5) = FormatNumber(objfile.Size / 1024, -1) '文件大小
        sht.Hyperlinks.Add anchor:=sht.Cells(n + 1, 6), Address:=fp & "\" & f, SubAddress:="", TextToDisplay:=f ''超链接
    End If
f = Dir
Loop
If n <> "" Then sht.[a2].Resize(n, 5) = arr
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub

3190496160

DATA.rar (21.03 KB, 下载次数: 56)

2022-11-15 21:25 上传

点击文件名下载附件

tyson_zhengsen

3190496160 发表于 2022-11-15 20:00
文件系统对象FSO基本可以搞定了，但是 ，不明白你说的第四点是什么意思，也就是，获取的A列的数据，如何呈 ...

你好，非常感谢前代码可以遍历到该指定文件夹的所有文件、以及生成超链接。
第4个问题是：如源文件所示，很多个".CSV"文件，每个文件里面A列有一些数据：
18301001
19.87
59.77
99.6
19.83
59.76
99.6
19.87
59.77
99.64
20.64
60.9
101
20.61
60.8
101
20.63
60.82
101
需要把这些数据提炼出来，汇总到工作表中，这些数据是列数据，需要转置到G、H、I、J、K.......行。
并且前提条件是不能打开源文件直接引用，需要VB实现。谢谢！！

3190496160

tyson_zhengsen 发表于 2022-11-16 12:33
你好，非常感谢前代码可以遍历到该指定文件夹的所有文件、以及生成超链接。
第4个问题是：如源文件所示 ...

呵呵呵，不知道你所追求的不打开文件是什么情况，要想获取数据，其实都得打开文件，即使是sql也得打开文件，只是打开的过程你看不到而已，

xiangbaoan

1. Sub test1()
   
2. 
   
3.   Dim p As String
   
4.   With Application.FileDialog(msoFileDialogFolderPicker)
   
5.     .InitialFileName = ThisWorkbook.Path
   
6.     If .Show Then p = .SelectedItems(1) Else Exit Sub
   
7.   End With
   
8.   If Right(p, 1) <> "\" Then p = p & "\"
   
9.   
   
10. '  Dim Fso As New FileSystemObject, Fil As File
    
11.   Dim ar, i As Long, ff As Byte
    
12.   Dim Fso As Object, Fil As Object
    
13.   Set Fso = CreateObject("Scripting.FileSystemObject")
    
14.   
    
15.   Cells.Clear
    
16.   
    
17.   For Each Fil In Fso.GetFolder(p).Files
    
18.     If LCase(Fil.Name) Like "*.csv" Then
    
19.         ff = FreeFile
    
20.         Open Fil.Path For Input As #ff
    
21.         ar = Split(StrConv(InputB(LOF(ff), #ff), vbUnicode), vbNewLine)
    
22.         Close #ff
    
23.         i = i + 1
    
24.         With ActiveSheet
    
25.           .Cells(i, 1) = p
    
26.           .Cells(i, 2) = Fil.Name
    
27.           .Cells(i, 3) = Fil.DateLastModified
    
28.           .Hyperlinks.Add .Cells(i, 4), Fil.Path, "", "点击链接到 " & Fil.Path, Fil.Name
    
29.           .Cells(i, 7).Resize(, UBound(ar) + 1) = ar
    
30.         End With
    
31.     End If
    
32.   Next
    
33.   Range("D1").Resize(i).Font.Underline = -4142
    
34.   
    
35.   Set Fso = Nothing
    
36.   Beep
    
37. End Sub

复制代码

3190496160

Sub 提取信息()
Application.ScreenUpdating = False
Dim ar As Variant, br As Variant
Dim i As Long
Dim arr()
Set sht = ThisWorkbook.Worksheets(1)
sht.[a1].CurrentRegion.Offset(1) = Empty
Set fso = CreateObject("Scripting.FileSystemObject")
Set obmapp = CreateObject("Shell.Application").BrowseForFolder(0, "请选择文件目录：", 0, 0)   '选择文件夹对话框
If obmapp Is Nothing Then MsgBox "您没有选择文件夹！": End '如果选择了文件夹
fp = obmapp.Self.Path   '把选择的文件夹的路劲赋值给变量fp
f = Dir(fp & "\*.csv")
ReDim arr(1 To 10000, 1 To 7)
Do While f <> ""
    If f <> ThisWorkbook.Name Then
        n = n + 1
        arr(n, 1) = fp '文件夹路劲
        arr(n, 2) = f '文件名称
        Set objfile = fso.GetFile(fp & "\" & f) '
        arr(n, 3) = objfile.DateLastModified '修改时间
        arr(n, 4) = objfile.DateCreated '文件创建时间
        arr(n, 5) = FormatNumber(objfile.Size / 1024, -1) '文件大小
        sht.Hyperlinks.Add anchor:=sht.Cells(n + 1, 6), Address:=fp & "\" & f, SubAddress:="", TextToDisplay:=f ''超链接
        Set wb = Workbooks.Open(fp & "\" & f, 0)
        With wb.Worksheets(1)
            r = .Cells(Rows.Count, 1).End(xlUp).Row
            ar = .Range("a1:a" & r)
        End With
        wb.Close False
        sht.Cells(n + 1, 7).Resize(1, UBound(ar)) = Application.Transpose(ar)
    End If
f = Dir
Loop
If n <> "" Then sht.[a2].Resize(n, 5) = arr
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub

3190496160

DATA.rar (22.5 KB, 下载次数: 65)

2022-11-21 09:17 上传

点击文件名下载附件