一、提取单层文件内的文件名
 
只会提取到文件，如果是文件夹自动忽略。
 
Sub FileDir()
    Dim p$, f$, k&
    '获取用户选择文件夹的路径
    With Application.FileDialog(msoFileDialogFolderPicker)
   '选择文件夹
        If .Show Then
            p = .SelectedItems(1)
            '选择的文件路径赋值变量P
        Else
            Exit Sub
            '如果没有选择保存路径，则退出程序
        End If
    End With
    If Right(p, 1) <> "\" Then p = p & "\"
    f = Dir(p & "*.*")
    '返回变量P指定路径下带任意扩展名的文件名
    '如果有超过一个文件存在，将返回第一个找到的文件名
    '如果一个文件都没有，则返回空
    [a:a].ClearContents '清空A列数据
    [a1] = "目录"
    k = 1
    Do While f <> ""
    '如果文件名不为空，则……
        k = k + 1
        '累加文件个数
        Cells(k, 1) = f
        f = Dir
        '第二次调用Dir函数，但不带任何参数，则将返回同一目录下的下一个文件。
    Loop
    MsgBox "OK"
End Sub
 
二、提取多层文件夹内的文件名
 
分别将文件夹名称和文件名提取在表格的A/B列，并对文件名创建了超链接
 
Sub AutoAddLink()
    Dim strFldPath As String
    With Application.FileDialog(msoFileDialogFolderPicker)
    '用户选择指定文件夹
        .Title = "请选择指定文件夹。"
        If .Show Then strFldPath = .SelectedItems(1) Else Exit Sub
        '未选择文件夹则退出程序，否则将地址赋予变量strFldPath
    End With
    Application.ScreenUpdating = False
    '关闭屏幕刷新
    Range("a:b").ClearContents
    Range("a1:b1") = Array("文件夹", "文件名")
    Call SearchFileToHyperlinks(strFldPath)
    '调取自定义函数SearchFileToHyperlinks
    Range("a:b").EntireColumn.AutoFit
    '自动列宽
    Application.ScreenUpdating = True
    '重开屏幕刷新
End Sub
Function SearchFileToHyperlinks(ByVal strFldPath As String) As String
    Dim objFld As Object
    Dim objFile As Object
    Dim objSubFld As Object
    Dim strFilePath As String
    Dim lngLastRow As Long
    Dim intNum As Integer
    Set objFld = CreateObject("Scripting.FileSystemObject").GetFolder(strFldPath)
    '创建FileSystemObject对象引用
    For Each objFile In objFld.Files
    '遍历文件夹内的文件
        lngLastRow = Cells(Rows.Count, 1).End(xlUp).Row + 1
        strFilePath = objFile.Path
        intNum = InStrRev(strFilePath, "\")
        '使用instrrev函数获取最后文件夹名截至的位置
        Cells(lngLastRow, 1) = Left(strFilePath, intNum - 1)
        '文件夹地址
        Cells(lngLastRow, 2) = Mid(strFilePath, intNum + 1)
        '文件名
        ActiveSheet.Hyperlinks.Add Anchor:=Cells(lngLastRow, 2), _
                    Address:=strFilePath, ScreenTip:=strFilePath
        '添加超链接
    Next objFile
    For Each objSubFld In objFld.SubFolders
    '遍历文件夹内的子文件夹
        Call SearchFileToHyperlinks(objSubFld.Path)
    Next objSubFld
    Set objFld = Nothing
    Set objFile = Nothing
    Set objSubFld = Nothing
End Function
 
 
 
 

该VBA脚本可以实现从word文档的多个表中提取数据，每个表格的信息提取到一行。
 
Sub word2els()
 Set wdApp = CreateObject(“kwps.application”)
 path_ = ThisWorkbook.Path
 wdApp.Documents.Open (path_ & “” & “bbb.doc”)
 wdApp.Visible = True
 ThisWorkbook.Sheets(“sheet1”).Cells(1, 1) = “序号” ‘’’ 设置sheet1的第一行第一列单元格内容为“序号”
 ThisWorkbook.Sheets(“sheet1”).Cells(1, 2) = “用例标识” ‘’’ 设置sheet1的第一行第一列单元格内容为“用例标识”
 ThisWorkbook.Sheets(“sheet1”).Cells(1, 3) = “测试类型” ‘’’ 设置sheet1的第一行第一列单元格内容为“测试类型”
 
n = wdApp.ActiveDocument.Tables.Count ‘’’'有多少个表格
 excel_line_no = 2
 For i = 1 To n
 zhs = wdApp.ActiveDocument.Tables(i).cell(2, 2) ‘’'提取第i个表格的第二行第三列单元格的内容保存到变量zhs中
 Version = wdApp.ActiveDocument.Tables(i).cell(3, 5) ‘’'提取第i个表格的第三行第五列单元格的内容保存到变量Version中
 env = wdApp.ActiveDocument.Tables(i).cell(3, 7) ‘’'提取第i个表格的第三行第七列单元格的内容保存到变量env中
 ThisWorkbook.Sheets(“Sheet1”).Cells(excel_line_no, 1) = zhs ‘’'将变量zhs的值写入到excel的sheet1的第’excel_line_no 行第1列
 ThisWorkbook.Sheets(“Sheet1”).Cells(excel_line_no, 2) = Version ‘’'将变量Version的值写入到excel的sheet1的第’excel_line_no 行第2列
 ThisWorkbook.Sheets(“Sheet1”).Cells(excel_line_no, 3) = env ‘’'将变量env的值写入到excel的sheet1的第’excel_line_no 行第3列
 excel_line_no = excel_line_no + 1
 Next
 wdApp.Application.Quit '关闭word文档
 Set wdApp = Nothing '释放对象变量的内存
 
End Sub
 
word文档如下：
 
 提取结果如下：
 

同事需求，要提取单线图中的所有焊口编号和检测报告中的做比对。网上找了个有些麻烦，不能选取非文本，否则报错。于是修改代码如下。 
 
用法：
 
1、打开cad文件
 
2、在VB编辑器中复制以下代码，然后运行
 
3、此时回到CAD，选取要提取的文本，如果都需要提取，则全选。 选取非文本时脚本会自动跳过。右键完成。
 
4、结果保存在d:/output.txt文件内。
 
Sub AcadGetText()
    
    Dim sset As AcadSelectionSet   '声明定义选择集
    Dim ent As AcadEntity          '声明实体
    Dim fso, f
    Dim filename As String         '声明文件字符串
    Dim str As String
    
    filename = "d:/output.txt"
    
    Do While ThisDrawing.SelectionSets.Count > 0
        ThisDrawing.SelectionSets.Item(0).Delete
    Loop
    
    Set sset = ThisDrawing.SelectionSets.Add("sst")  '添加选择集
    sset.SelectOnScreen                              '在屏幕上选择对象
    
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set f = fso.OpenTextFile(filename, 8, True)
    
    ' 可能选取到非文本，所以。。。
    On Error Resume Next
    For Each ent In sset
        str = ""
        str = ent.TextString
        If str <> "" Then f.WriteLine str
    Next
    
    f.Close
    
End Sub

 
参考于：https://blog.csdn.net/maokaijiang/article/details/5814147
 
自己修改了些代码，用于处理选取了非文本时报错问题。也更换了写文件的方式。
 
--
 
2021.1.19 锦采

Sub test()

Dim oDom As Object: Set oDom = CreateObject("htmlFile")
Dim x As Long, y As Long
Dim oRow As Object, oCell As Object
Dim data

y = 1: x = 1

With CreateObject("msxml2.xmlhttp")
'http://www.bundesbank.de/Navigation/EN/Statistics/Time_series_databases/Macro_economic_time_series/its_details_value_node.html?tsId=BBNZ1.Q.DE.Y.G.0000.A&listId=www_s311_b4_vgr_verw_nominal
    .Open "GET", "http://finance.yahoo.com/q/hp?s=GOOG+Historical+Prices", False
    .Send
    oDom.body.innerHtml = .responseText
End With

With oDom.getElementsByTagName("table")(0)
    ReDim data(1 To .Rows.Length, 1 To .Rows(1).Cells.Length)
    For Each oRow In .Rows
        For Each oCell In oRow.Cells
            data(x, y) = oCell.innerText
            y = y + 1
        Next oCell
        y = 1
        x = x + 1
    Next oRow
End With

Sheets(1).Cells(1, 1).Resize(UBound(data), UBound(data, 2)).Value = data
End Sub
 
 
 
这里是引用
 https://www.it1352.com/737536.html