求教各位大神！提取word表格内容时能不能保留原字体颜色

夜殇1999

求教各位大神！
批量提取word表格内容时能不能保留原字体颜色。。

如附件：word表格中的姓名是栏 字体是有颜色的
             汇总到excel表格中能不能保留原来的颜色。。。

liulang0808

附件中的excel文件损坏，无法打开

gwjkkkkk

重新上传附件。。。

夜殇1999

1. [code]Private Sub CommandButton1_Click()
   
2.   On Error Resume Next
   
3.   Dim wordapp As Object, mytab As Object
   
4.   Dim mydoc
   
5.   Dim dirpath$, myfile$, docname$
   
6. '创建wor d应用程序对象
   
7.   Set wordapp = CreateObject("word.application")
   
8. '定义wor d文件存放路径
   
9. dirpath = ThisWorkbook.Path & "/word/"
   
10. 
    
11. myfile = Dir(dirpath & "*.docx")
    
12. 
    
13. i = 2
    
14. '循环读取文件夹下文档
    
15. Range("a2:h10000").ClearContents
    
16. 
    
17. Do While myfile <> ""
    
18. 
    
19.    Set mydoc = wordapp.Documents.Open(dirpath & myfile)
    
20.    Set mytab = mydoc.tables(1)
    
21. 
    
22.     Cells(i, 1) = tt(mytab.Cell(1, 2).Range.Text)
    
23.     Cells(i, 2) = tt(mytab.Cell(1, 4).Range.Text)
    
24.     Cells(i, 3) = tt(mytab.Cell(2, 2).Range.Text)
    
25.     Cells(i, 4) = tt(mytab.Cell(2, 4).Range.Text)
    
26.     myfile = Dir
    
27.     i = i + 1
    
28.     Loop
    
29. 
    
30. mydoc.Close False
    
31. wordapp.Quit
    
32. End Sub

复制代码

夜殇1999

liulang0808 发表于 2024-3-29 21:12
附件中的excel文件损坏，无法打开

1. [code][code]Private Sub CommandButton1_Click()
   
2.   On Error Resume Next
   
3.   Dim wordapp As Object, mytab As Object
   
4.   Dim mydoc
   
5.   Dim dirpath$, myfile$, docname$
   
6. '创建wor d应用程序对象
   
7.   Set wordapp = CreateObject("word.application")
   
8. '定义wor d文件存放路径
   
9. dirpath = ThisWorkbook.Path & "/word/"
   
10. 
    
11. myfile = Dir(dirpath & "*.docx")
    
12. 
    
13. i = 2
    
14. '循环读取文件夹下文档
    
15. Range("a2:h10000").ClearContents
    
16. 
    
17. Do While myfile <> ""
    
18. 
    
19.    Set mydoc = wordapp.Documents.Open(dirpath & myfile)
    
20.    Set mytab = mydoc.tables(1)
    
21. 
    
22.     Cells(i, 1) = tt(mytab.Cell(1, 2).Range.Text)
    
23.     Cells(i, 2) = tt(mytab.Cell(1, 4).Range.Text)
    
24.     Cells(i, 3) = tt(mytab.Cell(2, 2).Range.Text)
    
25.     Cells(i, 4) = tt(mytab.Cell(2, 4).Range.Text)
    
26.     myfile = Dir
    
27.     i = i + 1
    
28.     Loop
    
29. 
    
30. mydoc.Close False
    
31. wordapp.Quit
    
32. End Sub

复制代码

[/code]

大神有空麻烦再试下附件1

gwjkkkkk

Option Explicit
Sub TEST()
    Dim ar, br, i&, j&, r&, wdApp As Word.Application, strFileName$, strPath$
   
    Application.ScreenUpdating = False
    ReDim ar(1 To 2, 3)
    br = Array(2, 4, 6, 8)
    [A1].CurrentRegion.Offset(1).ClearContents
    r = 1
   
    On Error Resume Next
    Set wdApp = GetObject(, "Word.Application")
    If Err <> 0 Then
        Set wdApp = New Word.Application
    End If
   
    strPath = ThisWorkbook.Path & "\word\"
    strFileName = Dir(strPath & "*.doc*")
    Do Until strFileName = ""
        With wdApp.documents.Open(strPath & strFileName)
            With .tables(1)
                For j = 0 To UBound(br)
                    ar(1, j) = Left(.Range.Cells(br(j)).Range.Text, Len(.Range.Cells(br(j)).Range.Text) - 2)
                    ar(2, j) = .Range.Cells(br(j)).Range.Font.Color
                Next j
            End With
            .Close False
        End With
        r = r + 1
        For j = 0 To UBound(ar, 2)
            Cells(r, j + 1).Value = ar(1, j)
            Cells(r, j + 1).Font.Color = ar(2, j)
        Next j
        strFileName = Dir
    Loop
        
    If Err <> 0 Then wdApp.Quit
    Set wdApp = Nothing
    Application.ScreenUpdating = True
    Beep
End Sub

gwjkkkkk

请参考。、、

bxm78

加一名代码：
Cells(i, 1).Font.Color = mytab.cell(1, 2).Range.Font.Color