[已解决]如何将WORD内表格的内容按要求复制到EXCEL上

jian82372387

将WORD表格内每一行内每个单元格内容用"逗号"将所有内容连接起来复制到excelF列中，将检测人员名字复制到H列单中，如附件所示

最佳答案

月排行榜 / 总排行榜

cutecpu

2021-10-31 21:17

jian82372387 发表于 2021-10-31 21:10
上传了

试试下面代码，增加蓝色部份

Sub demo()
   Set doc = GetObject(ThisWorkbook.Path & "\demo.docx")
   [f5:h99].ClearContents
   With doc.tables(1)
      For i = 2 To .Rows.Count
         s = ""
         For j = 1 To .Columns.Count
            s = s + "," + replace(.Cell(i, j).Range.Text,chr(13) & chr(7),"")
         Next
         [f5].Offset(r).Resize(, 3) = Array(Mid(s, 2, 99), , replace(.Cell(i, 2).Range.Text,chr(13) & chr(7),""))
         r = r + 1
      Next
   End With
End Sub

跳转到最佳答案楼层

cutecpu

祝順心，南無阿彌陀佛！

jian82372387

cutecpu 发表于 2021-10-31 19:57
大侠，我这边没有出现您说的那个问题

代码是这样吗？？运行后会有“口”符号，点击单元格后就里面的内容自动换行。是代码又些符号又变乱码了吗？

Sub demo()
   Set doc = GetObject(ThisWorkbook.Path & "\demo.docx")
   [f5:h99].ClearContents
   With doc.tables(1)
      For i = 2 To .Rows.Count
         s = ""
         For j = 1 To .Columns.Count
            s = s + "," + .Cell(i, j).Range.Text
         Next
         [f5].Offset(r).Resize(, 3) = Array(Mid(s, 2, 99), , .Cell(i, 2).Range.Text)
         r = r + 1
      Next
   End With
End Sub

cutecpu

jian82372387 发表于 2021-10-31 19:59
代码是这样吗？？运行后会有“口”符号，点击单元格后就里面的内容自动换行。是代码又些符号又变乱码了吗 ...

试试下面代码，增加红色部份

Sub demo()
   Set doc = GetObject(ThisWorkbook.Path & "\demo.docx")
   [f5:h99].ClearContents
   With doc.tables(1)
      For i = 2 To .Rows.Count
         s = ""
         For j = 1 To .Columns.Count
            s = s + "," + replace(.Cell(i, j).Range.Text,chr(13),"")
         Next
         [f5].Offset(r).Resize(, 3) = Array(Mid(s, 2, 99), , replace(.Cell(i, 2).Range.Text,chr(13),""))
         r = r + 1
      Next
   End With
End Sub

jian82372387

cutecpu 发表于 2021-10-31 20:22
试试下面代码，增加红色部份

Sub demo()

版主，还是不行，但是双击单元格后那个符号就自动没有了

cutecpu

jian82372387 发表于 2021-10-31 21:01
版主，还是不行，但是双击单元格后那个符号就自动没有了

您上传不行的附件，我来看一下

jian82372387

cutecpu 发表于 2021-10-31 21:04
您上传不行的附件，我来看一下

上传了

cutecpu

jian82372387 发表于 2021-10-31 21:10
上传了

试试下面代码，增加蓝色部份

Sub demo()
   Set doc = GetObject(ThisWorkbook.Path & "\demo.docx")
   [f5:h99].ClearContents
   With doc.tables(1)
      For i = 2 To .Rows.Count
         s = ""
         For j = 1 To .Columns.Count
            s = s + "," + replace(.Cell(i, j).Range.Text,chr(13) & chr(7),"")
         Next
         [f5].Offset(r).Resize(, 3) = Array(Mid(s, 2, 99), , replace(.Cell(i, 2).Range.Text,chr(13) & chr(7),""))
         r = r + 1
      Next
   End With
End Sub

jian82372387

cutecpu 发表于 2021-10-31 21:17
试试下面代码，增加蓝色部份

Sub demo()

可以了，十分感谢