ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

快捷登录

搜索
EH技术汇-专业的职场技能充电站 妙哉!函数段子手趣味讲函数 Excel服务器-会Excel,做管理系统 效率神器,一键搞定繁琐工作
HR薪酬管理数字化实战 Excel 2021函数公式学习大典 Excel数据透视表实战秘技 打造核心竞争力的职场宝典
让更多数据处理,一键完成 数据工作者的案头书 免费直播课集锦 ExcelHome出品 - VBA代码宝免费下载
用ChatGPT与VBA一键搞定Excel WPS表格从入门到精通 Excel VBA经典代码实践指南
12
返回列表 发新帖
楼主: 幻想中的猪

[求助] 批量提取word中内容及word文件名到excel

[复制链接]

TA的精华主题

TA的得分主题

 楼主| 发表于 2018-7-5 16:39 | 显示全部楼层

感谢大侠帮我解决了问题。还有后续的问题想继续请教下:
1、我尝试过复制代码到其他表发现没起效,后来看代码发现其中有sheet1字样,是否表示到其他表中使用就修改这处的表名即可?
2、 Sheet1.Cells(LastRow, 10) = Trim(Split(Split(Split(.Range, "到期时间")(1), Chr(13))(1), Chr(7))(1))这句话我懂,但是我能看出效果是取到期时间后的值,并放在第10列。通过大侠的代码我想自己增加一列,取“办理意见”,但是简单的依葫芦画瓢发现, Sheet1.Cells(LastRow, 11) = Trim(Split(Split(Split(.Range, "办理意见")(1), Chr(13))(1), Chr(7))(1))在办理意见有多个段落的时候只取了第一个回车前的内容,那么我应该如何修改呢?

TA的精华主题

TA的得分主题

 楼主| 发表于 2018-7-5 17:30 | 显示全部楼层

另外还有一个问题,就是在word文件的序列中,偶尔间杂了几个内容中的格式不一样(无表格,纯文本),运行结果是:当内容中存在1-10列对应关键字时,生成一行且文件名正确取用;当不存在1-10列对应关键字时,不生成行,特殊地,当这个特别文件刚好排最后时生成一行且1-10列为空而仅取用文件名。

从结果来看,大侠的取值算法应该是取用关键字后第一个回车前的字符串。那么如何能对应夹杂在中间的纯文本word文件都分别生成一行呢,无论1-10列是否为空,有个最后的文件名也好。

TA的精华主题

TA的得分主题

发表于 2018-7-5 17:35 来自手机 | 显示全部楼层

TA的精华主题

TA的得分主题

发表于 2018-7-6 08:52 | 显示全部楼层
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用  · 内置多项VBA编程加强工具       ★ 免费下载 ★      ★使用手册
  1. Sub GetStrByWord()
  2.     Dim SH As Worksheet, lngRowIndex As Long
  3.     Dim strFileName As String, strPath As String, strTemp As String
  4.     Dim strID As String, strName As String, strMemo As String
  5.     Dim objDoc As Object, objTable  As Object
  6.     Dim arrResult(1 To 1, 1 To 10) As Variant
  7.    
  8.     Set SH = Sheets("Sheet1")
  9.     lngRowIndex = SH.Range("A" & Rows.Count).End(xlUp).Row
  10.     If lngRowIndex < 2 Then lngRowIndex = 2
  11.     SH.Range("A2:J" & lngRowIndex).ClearContents
  12.     lngRowIndex = 2
  13.    
  14.     Application.ScreenUpdating = False
  15.     Application.Cursor = xlWait
  16.    
  17.     strPath = ThisWorkbook.Path
  18.     strFileName = Dir(strPath & "" & "*.doc*")
  19.    
  20.     Do Until strFileName = ""
  21.         strTemp = Split(strFileName, ".")(0)
  22.         strID = Mid(strTemp, 1, 4)
  23.         
  24.         strTemp = Mid(strTemp, 5)
  25.         If InStr(strTemp, "(") > 0 Then
  26.             strName = Split(strTemp, "(")(0)
  27.             strMemo = Split(strTemp, "(")(1)
  28.             strMemo = Mid(strMemo, 1, Len(strMemo) - 1)
  29.         Else
  30.             strName = strTemp
  31.             strMemo = ""
  32.         End If
  33.         
  34.         Set objDoc = GetObject(strPath & "" & strFileName)
  35.         If objDoc.tables.Count > 0 Then
  36.             Set objTable = objDoc.tables(1)
  37.             arrResult(1, 1) = strID
  38.             arrResult(1, 2) = strName
  39.             arrResult(1, 3) = strMemo
  40.             arrResult(1, 4) = Replace(objTable.Cell(2, 2).Range.Text, Chr(13) & Chr(7), "")
  41.             arrResult(1, 5) = Replace(objTable.Cell(2, 4).Range.Text, Chr(13) & Chr(7), "")
  42.             arrResult(1, 6) = Replace(objTable.Cell(3, 4).Range.Text, Chr(13) & Chr(7), "")
  43.             arrResult(1, 7) = Replace(objTable.Cell(4, 2).Range.Text, Chr(13) & Chr(7), "")
  44.             arrResult(1, 8) = Replace(objTable.Cell(4, 4).Range.Text, Chr(13) & Chr(7), "")
  45.             arrResult(1, 9) = Replace(objTable.Cell(6, 2).Range.Text, Chr(13) & Chr(7), "")
  46.             arrResult(1, 10) = Replace(objTable.Cell(7, 4).Range.Text, Chr(13) & Chr(7), "")
  47.             SH.Range("A" & lngRowIndex).Resize(1, 10) = arrResult
  48.             lngRowIndex = lngRowIndex + 1
  49.         End If
  50.         objDoc.Close False
  51.         strFileName = Dir()
  52.     Loop
  53.         Set objDoc = Nothing
  54.    
  55.     Application.ScreenUpdating = True
  56.     Application.Cursor = xlDefault
  57.     MsgBox "导入成功!共导入信息【" & lngRowIndex - 2 & "】条"
  58. End Sub

复制代码

TA的精华主题

TA的得分主题

 楼主| 发表于 2018-7-22 18:56 | 显示全部楼层
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助

谢谢。不过代码我试用了结果是导入“0”条。。。我用了上面的yylucke老师的做法,基本解决了问题,然后利用“办理意见”总是最后一个栏目的特点,稍微修改了语句将其后的全部字符串都引用,然后批量删除不要的字符,解决了99%的问题。

TA的精华主题

TA的得分主题

发表于 2023-9-25 16:37 | 显示全部楼层
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助
  楼主| 发表于 2018-7-5 16:39 | 只看该作者

请问这个不能提取全部段落内容的问题是要怎么解决呢

TA的精华主题

TA的得分主题

发表于 2023-9-25 16:38 | 显示全部楼层
幻想中的猪 发表于 2018-7-5 16:39
感谢大侠帮我解决了问题。还有后续的问题想继续请教下:
1、我尝试过复制代码到其他表发现没起效,后来 ...

请问这个问题是需要怎么解决,感谢指导

TA的精华主题

TA的得分主题

发表于 2024-9-10 22:21 | 显示全部楼层
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用  · 内置多项VBA编程加强工具       ★ 免费下载 ★      ★使用手册

牛逼。牛逼。牛逼。牛逼。牛逼。牛逼。

TA的精华主题

TA的得分主题

发表于 2024-9-11 12:39 | 显示全部楼层
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用  · 内置多项VBA编程加强工具       ★ 免费下载 ★      ★使用手册
平常心  我有时间 我来写一个  

  1. Sub GetData()

  2.     Set wb = Application.ThisWorkbook

  3.     Set sht = wb.Worksheets(1)

  4.     sht.UsedRange.Offset(1).Clear

  5.     sht.Cells.NumberFormatLocal = "@"

  6.     Set reg = CreateObject("VBScript.RegExp")

  7.     With reg

  8.         .Global = True

  9.         .Pattern = "[一-龟]+"

  10.     End With
  11.     Set reg2 = CreateObject("VBScript.RegExp")

  12.     With reg2

  13.         .Global = True

  14.         .Pattern = "((.*?))"

  15.     End With

  16.     fd = wb.Path & ""

  17.     i = 1

  18.     Set fs = CreateObject("Scripting.FileSystemObject").GetFolder(fd).Files

  19.     For Each f In fs

  20.         fn = f.Name

  21.         fp = f.Path

  22.         If fp Like "*.doc*" And Not fp Like "*~*" Then

  23.             Debug.Print fp

  24.             Set doc = GetObject(fp)

  25.             Set tb = doc.tables(1)

  26.             i = i + 1

  27.             Debug.Print doc.Name

  28.             sht.Cells(i, 1).Value = Left(doc.Name, 4)

  29.             sht.Cells(i, 2).Value = reg.Execute(doc.Name)(0)

  30.             If reg2.test(doc.Name) Then sht.Cells(i, 3).Value = reg2.Execute(doc.Name)(0).submatches(0)

  31.             sht.Cells(i, 4).Value = Application.Clean(tb.Range.Cells(3).Range.Text)

  32.             sht.Cells(i, 5).Value = Application.Clean(tb.Range.Cells(5).Range.Text)

  33.             sht.Cells(i, 6).Value = Application.Clean(tb.Range.Cells(9).Range.Text)

  34.             sht.Cells(i, 7).Value = Application.Clean(tb.Range.Cells(11).Range.Text)

  35.             sht.Cells(i, 8).Value = Application.Clean(tb.Range.Cells(13).Range.Text)

  36.             sht.Cells(i, 9).Value = Application.Clean(tb.Range.Cells(19).Range.Text)

  37.             sht.Cells(i, 10).Value = Application.Clean(tb.Range.Cells(23).Range.Text)

  38.             sht.Cells(i, 11).Value = doc.Name

  39.             doc.Close False

  40.         End If
  41.     Next
  42. End Sub
复制代码
您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

手机版|关于我们|联系我们|ExcelHome

GMT+8, 2024-11-18 22:49 , Processed in 0.044600 second(s), 6 queries , Gzip On, MemCache On.

Powered by Discuz! X3.4

© 1999-2023 Wooffice Inc.

沪公网安备 31011702000001号 沪ICP备11019229号-2

本论坛言论纯属发表者个人意见,任何违反国家相关法律的言论,本站将协助国家相关部门追究发言者责任!     本站特聘法律顾问:李志群律师

快速回复 返回顶部 返回列表