Sub GetWordText改进()
Dim Wb As Workbook
Dim Sht As Worksheet
Dim Rng As Range Dim wdApp As Object
Dim wdDoc As Object
Dim FilePaths
Dim FilePath
Dim Arr(1 To 10000, 1 To 6)
Dim n As Long
Dim Index As Long Dim Regex As Object
Dim Mh As Object
Pattern = ".*?[::](\S*)\s*?.*?[::](\S*)\s*?" & _
".*?[::](\S*)\s*?.*?[::](\S*)\s*?" & _
".*?[::](\S*)\s*?.*?[::](\S*)"
Set Regex = CreateObject("VBScript.RegExp")
With Regex
.Global = True
.Pattern = Pattern
End With Set Wb = Application.ThisWorkbook
Set Sht = Wb.Worksheets("汇总")
With Sht
.UsedRange.Offset(1).ClearContents
End With
FilePaths = FsoGetFiles(Wb.Path & "\", "*.doc*")
If FilePaths(1) = "None" Then Exit Sub
Index = 0 Set wdApp = CreateObject("Word.Application")
For n = LBound(FilePaths) To UBound(FilePaths) 'On Error Resume Next
Set wdDoc = wdApp.documents.Open(FilePaths(n))
If wdDoc Is Nothing Then
GoTo NextDocument
Else
If wdDoc.Tables.Count > 0 Then
Debug.Print "含表格:"; FilePaths(n)
Index = Index + 1
For j = 1 To 6
Text = wdDoc.Tables(1).cell(1, j).Range.Text
Text = Replace(Text, Chr(10), "")
Text = Replace(Text, Chr(7), "")
Text = Replace(Text, Chr(13), "")
Arr(Index, j) = "'" & Text
Debug.Print Index; " "; Arr(Index, j)
Next j
Else
Debug.Print "纯文本:"; FilePaths(n)
If Regex.test(wdDoc.Content.Text) Then
Set Mh = Regex.Execute(wdDoc.Content.Text)
Index = Index + 1
For j = 0 To Mh.Item(0).submatches.Count - 1
Arr(Index, j + 1) = "'" & Mh.Item(0).submatches(j)
Debug.Print Index; " "; Arr(Index, j + 1)
Next j
End If
End If
End If
wdDoc.Close False
NextDocument:
On Error GoTo 0
Next n wdApp.Quit With Sht
Set Rng = .Range("A2")
Set Rng = Rng.Resize(UBound(Arr), UBound(Arr, 2))
Rng.Value = Arr
End With Set Wb = Nothing
Set Sht = Nothing
Set Rng = Nothing
Set wdApp = Nothing
Set wdDoc = Nothing End Sub
Function FsoGetFiles(ByVal FolderPath As String, ByVal Pattern As String, Optional ComplementPattern As String = "") As String()
Dim Arr() As String
Dim FSO As Object
Dim ThisFolder As Object
Dim OneFile As Object
ReDim Arr(1 To 1)
Arr(1) = "None"
Dim Index As Long
Index = 0
Set FSO = CreateObject("Scripting.FileSystemObject")
On Error GoTo ErrorExit
Set ThisFolder = FSO.getfolder(FolderPath)
If Err.Number <> 0 Then Exit Function
For Each OneFile In ThisFolder.Files
If OneFile.Name Like Pattern Then
If Len(ComplementPattern) > 0 Then
If Not OneFile.Name Like ComplementPattern Then
Index = Index + 1
ReDim Preserve Arr(1 To Index)
Arr(Index) = OneFile.Path '& OneFile.Name
End If
Else
Index = Index + 1
ReDim Preserve Arr(1 To Index)
Arr(Index) = OneFile.Path '& OneFile.Name
End If
End If
Next OneFile
ErrorExit:
FsoGetFiles = Arr
Erase Arr
Set FSO = Nothing
Set ThisFolder = Nothing
Set OneFile = Nothing
End Function

  

20171022xlVBA练手提取入所记录的更多相关文章

  1. 【Python】【辅助程序】练手小程序:记录外网动态IP地址

    练手小程序 程序作用:对IP实时记录: 1.定时获取外网IP,存储在本地文件中: 编写思路: 1)收集获取外网的API接口       http://bbs.125.la/thread-1383897 ...

  2. 练手项目之image caption问题记录

    小白一个,刚刚费了老大的劲完成一个练手项目--image caption,虽然跑通了,但是评估结果却惨不忍睹.于是贴上大神的作品,留待日后慢慢消化.顺便记录下自己踩坑的一些问题. 先膜拜下大神的作品. ...

  3. 去哪找Java练手项目?

    经常有读者在微信上问我: 在学编程的过程中,看了不少书.视频课程,但是看完.听完之后感觉还是不会编程,想找一些项目来练手,但是不知道去哪儿找? 类似的问题,有不少读者问,估计是大部分人的困惑. 练手项 ...

  4. 简单的node爬虫练手,循环中的异步转同步

    简单的node爬虫练手,循环中的异步转同步 转载:https://blog.csdn.net/qq_24504525/article/details/77856989 看到网上一些基于node做的爬虫 ...

  5. Python练手项目:20行爬取全王者全英雄皮肤

    引言    王者荣耀大家都玩过吧,没玩过的也应该听说过,作为时下最火的手机MOBA游戏,咳咳,好像跑题了.我们今天的重点是爬取王者荣耀所有英雄的所有皮肤,而且仅仅使用20行Python代码即可完成. ...

  6. webpack练手项目之easySlide(三):commonChunks(转)

    Hello,大家好. 在之前两篇文章中: webpack练手项目之easySlide(一):初探webpack webpack练手项目之easySlide(二):代码分割 与大家分享了webpack的 ...

  7. Python之路【第二十四篇】:Python学习路径及练手项目合集

      Python学习路径及练手项目合集 Wayne Shi· 2 个月前 参照:https://zhuanlan.zhihu.com/p/23561159 更多文章欢迎关注专栏:学习编程. 本系列Py ...

  8. 初始Spring MVC——练手小项目

    初始Spring MVC 前几天开始了我的spring学习之旅,由于之前使用过MVC模式来做项目,所以我先下手的是 Spring MVC,做个练手项目,非常简单 项目介绍: 用户输入信息 -> ...

  9. 70个Python练手项目列表(都有完整教程)

    前言: 不管学习那门语言都希望能做出实际的东西来,这个实际的东西当然就是项目啦,不用多说大家都知道学编程语言一定要做项目才行. 这里整理了70个Python实战项目列表,都有完整且详细的教程,你可以从 ...

随机推荐

  1. vsCode设置中文

    1.安装软件之后,关闭欢迎界面,Ctrl+shift+p打开命令窗口,输入lang,选择configuration display language,改为 "locale":&qu ...

  2. Python3基础 list insert 在指定位置挤入一个元素

             Python : 3.7.0          OS : Ubuntu 18.04.1 LTS         IDE : PyCharm 2018.2.4       Conda ...

  3. Intellij IDEA 安装配置Gradle

    1.安装 到官网链接下载最新的bin版本,解压到 D:\Program Files (x86)\JetBrains\IDEA Configuration And Cache\gradle 配置环境变量 ...

  4. C# DataTable.Compute()用法

    DataTable.Compute()用法 2010-04-07 11:28 一.DataTable.Compute()方法說明如下 作用:          计算用来传递筛选条件的当前行上的给定表达 ...

  5. URL重定向及跳转漏洞

    URL跳转漏洞 URL 跳转漏洞是指后台服务器在告知浏览器跳转时,未对客户端传入的重定向地址进行合法性校验,导致用户浏览器跳转到钓鱼页面的一种漏洞. 使用场景    现在 Web 登录很多都接入了QQ ...

  6. transient关键字详解

    作用 1,一旦变量被transient修饰,变量将不再是对象持久化的一部分,该变量内容在序列化后无法获得访问. 2,transient关键字只能修饰变量,而不能修饰方法和类.注意,本地变量是不能被tr ...

  7. Qt中中文字符 一劳永逸的解决方法

    QT中中文字符问题,有没有一劳永逸的解决方法? 目前遇到有以下问题 1.字符串中有中文时,编译提示"常量中含有换行符" 2.在控制台窗口输出中文时无法正常显示,中文全部显示为? 目 ...

  8. C+++string类如何判断字符串为空

    string类是C++STL类之一,有很丰富的接口,判断string为空是经常用到的操作. string类为空,实际也就是元素为0个. 可以按照如下方式判断: 1.string类有自己的成员函数emp ...

  9. 1. dubbo概述

    dubbo简介: 官网:http://dubbo.io 最大程度进行解耦,降低系统耦合性,可以跨工程,跨项目; 生产者/消费者模式; jdk:1.6以上 maven:3.0以上 国际maven仓库:h ...

  10. hbase非结构化数据库与结构化数据库比较

    目的:了解hbase与支持海量数据查询的特性以及实现方式 传统关系型数据库特点及局限 传统数据库事务性特别强,要求数据完整性及安全性,造成系统可用性以及伸缩性大打折扣.对于高并发的访问量,数据库性能不 ...