Chuyển dữ liệu từ Word sang Excel.

Chia sẻ bởi:hands

★★★★★

‹ Gộp nhiều file word và giữ nguyên... [Chia sẻ] Phối hợp chuyển đổi qua... ›

Quảng cáo

Mình có 2 file "Nguồn" và "đích".(đính kèm). Mình muốn hỏi có hàm nào để chuyển dữ kiệu từ Word sang Excell được không(Không coppy và pates thủ công). Dữ liệu thật của mình rất dài.

Code:

Sub GetWordTable()
  Dim vFile, arr(), tmp As String
  Dim lR As Long, lC As Long, lRs As Long, lCs As Long, i As Long
  On Error Resume Next
  vFile = Application.GetOpenFilename("Word files (*.doc),*.doc")
  If TypeName(vFile) = "String" Then
    With GetObject(vFile)
      If .Tables.Count Then
        For i = 1 To .Tables.Count
          lRs = .Tables(i).Rows.Count
          lCs = .Tables(i).Columns.Count
          ReDim arr(1 To lRs, 1 To lCs)
          For lR = 2 To lRs
            For lC = 1 To lCs
              tmp = .Tables(i).Cell(lR, lC).Range.Text
              arr(lR, lC) = WorksheetFunction.Clean(tmp)
            Next
          Next
          Range("A60000").End(xlUp).Offset(1).Resize(lRs, lCs).Value = arr
        Next
      End If
      .Close
    End With
  End If
End Sub

Nếu muốn paste vào ActiveCell thì có nghĩa là cho dù Word có bao nhiều Table thì bạn cũng luôn lấy Table 1

Sub GetWordTable()
  Dim vFile, arr(), tmp As String
  Dim lR As Long, lC As Long, lRs As Long, lCs As Long, i As Long
  On Error Resume Next
  vFile = Application.GetOpenFilename("Word files (*.doc),*.doc")
  If TypeName(vFile) = "String" Then
    With GetObject(vFile)
      If .Tables.Count Then
        lRs = .Tables(1).Rows.Count
        lCs = .Tables(1).Columns.Count
        ReDim arr(1 To lRs, 1 To lCs)
        For lR = 2 To lRs
          For lC = 1 To lCs
            tmp = .Tables(1).Cell(lR, lC).Range.Text
            arr(lR, lC) = WorksheetFunction.Clean(tmp)
          Next
        Next
        ActiveCell.Resize(lRs, lCs).Value = arr
      End If
      .Close
    End With
  End If
End Sub