Chuyển dữ liệu từ Word sang Excel. (1 người xem)

sinhthanh1984 · 26/6/13

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.

ndu96081631 · 27/6/13

sinhthanh1984 đã viết:
Thầy ơi File mẫu của em đây ạ.

Đúng là Word nó khác hoàn toàn so với Text File

Tạm dùng cách này xem:

Mã:

Sub GetWordTable()
  Dim vFile, arr(), 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
          .Tables(i).Range.Copy
          Range("A60000").End(xlUp).Offset(1).PasteSpecial 3
        Next
      End If
      .Close
    End With
  End If
End Sub

sinhthanh1984 · 27/6/13

Thầy ơi em test thử rồi code chạy khá tốt. Chỉ có điều em chỉ muốn coppy số TT và họ tên thôi còn các tiêu đề trường thì bỏ qua. Không cần coppy lại nữa ạ.

ndu96081631 · 27/6/13

sinhthanh1984 đã viết:
Thầy ơi em test thử rồi code chạy khá tốt. Chỉ có điều em chỉ muốn coppy số TT và họ tên thôi còn các tiêu đề trường thì bỏ qua. Không cần coppy lại nữa ạ.

Thế thì phải "thêm việc"

Mã:

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

EXCEL2020 · 27/6/13

ndu96081631 đã viết:

Đúng là Word nó khác hoàn toàn so với Text File

Tạm dùng cách này xem:

Mã:

Sub GetWordTable()
  Dim vFile, arr(), 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
          .Tables(i).Range.Copy
          Range("A60000").End(xlUp).Offset(1).PasteSpecial 3
        Next
      End If
      .Close
    End With
  End If
End Sub

Dear anh Ndu,
Em đổi lại từ code của anh file doc thành excel để import excel =>ok. Nhưng chỉ import được 2 cột mặc dù em đã thêm nhiều cột ở file nguồn.Nếu file nguồn có số cột thay đổi bất kì mình sửa sao anh.

ndu96081631 · 27/6/13

EXCEL2020 đã viết:
Dear anh Ndu,
Em đổi lại từ code của anh file doc thành excel để import excel =>ok. Nhưng chỉ import được 2 cột mặc dù em đã thêm nhiều cột ở file nguồn.Nếu file nguồn có số cột thay đổi bất kì mình sửa sao anh.

Bạn nói gì tôi chẳng hiểu
Muốn gì thì phải có file minh họa bạn à
Mà Word là Word, Excel là Excel... sao lại có chuyện lấy Word áp dụng cho Excel là thế nào.. tôi đếch hiểu

sinhthanh1984 · 28/6/13

ndu96081631 đã viết:

Tạm dùng cách này xem:

Mã:

Sub GetWordTable()
  Dim vFile, arr(), 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
          .Tables(i).Range.Copy
          Range("A60000").End(xlUp).Offset(1).PasteSpecial 3
        Next
      End If
      .Close
    End With
  End If
End Sub

Em cảm ơn thầy nhiều lắm. Code chạy rất tốt thầy ạ.
Thầy ơi thầy sửa code giúp em để mỗi lần chạy code này thì dữ liệu từ word sẽ coppy vào vị trí ô hiện hành tại excel. Theo như code của thầy thì mỗi lần chạy dữ liệu sẽ được "dán" vào dưới cột dữ liệu lúc trước thầy ah.

sinhthanh1984 · 28/6/13

Thầy ndu96081631 code này chỉ áp dụng được cho file nguồn có 2 cột thôi . Thầy sửa hộ em để áp dụng trong trường hợp File nguồn có nhiều cột với. Em cảm ơn thầy nhiều.

TrungChinhs · 28/6/13

sinhthanh1984 đã viết:
Em cảm ơn thầy nhiều lắm. Code chạy rất tốt thầy ạ.
Thầy ơi thầy sửa code giúp em để mỗi lần chạy code này thì dữ liệu từ word sẽ coppy vào vị trí ô hiện hành tại excel. Theo như code của thầy thì mỗi lần chạy dữ liệu sẽ được "dán" vào dưới cột dữ liệu lúc trước thầy ah.

Bạn sửa lại câu lệnh

Range("A60000").End(xlUp).Offset(1).PasteSpecial 3

thành

Selection.PasteSpecial 3

sinhthanh1984

Thầy ndu96081631 code này chỉ áp dụng được cho file nguồn có 2 cột thôi . Thầy sửa hộ em để áp dụng trong trường hợp File nguồn có nhiều cột với. Em cảm ơn thầy nhiều.

Làm gì có chuyện ấy, bao nhiêu cột mà chả được miễn là không lớn hơn 255 cột (chưa test)

sinhthanh1984 · 28/6/13

TrungChinhs đã viết:
Bạn sửa lại câu lệnh

Range("A60000").End(xlUp).Offset(1).PasteSpecial 3

thành

Selection.PasteSpecial 3

Làm gì có chuyện ấy, bao nhiêu cột mà chả được miễn là không lớn hơn 255 cột (chưa test)

Đúng vậy bạn ạ. Bao nhiêu cột cũng được. Tại dữ liệu nguồn của em lôn xộn quá nên khi test thử bị sai.

sinhthanh1984 · 28/6/13

Bạn sửa lại câu lệnh

Range("A60000").End(xlUp).Offset(1).PasteSpecial 3

thành

Selection.PasteSpecial 3

Bạn ơi sửa giúp mình sau mỗi lần pate thì sẽ vào vị trí ô hiện hành với nhưng từ code này:

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 IfEnd Sub

sinhthanh1984 · 28/6/13

TrungChinhs đã viết:
Bạn sửa lại câu lệnh

Range("A60000").End(xlUp).Offset(1).PasteSpecial 3

thành

Selection.PasteSpecial 3

Bạn giúp mình vẫn yêu cầu như vậy nhưng ở đoạn code này cơ:

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

sinhthanh1984 · 28/6/13

Thầy ndu96081631

Em cảm ơn thầy nhiều lắm. Code chạy rất tốt thầy ạ.
Thầy ơi thầy sửa code giúp em để mỗi lần chạy code này thì dữ liệu từ word sẽ coppy vào vị trí ô hiện hành tại excel. Theo như code của thầy thì mỗi lần chạy dữ liệu sẽ được "dán" vào dưới cột dữ liệu lúc trước thầy ah.

ndu96081631 · 28/6/13

sinhthanh1984 đã viết:

Bạn giúp mình vẫn yêu cầu như vậy nhưng ở đoạn code này cơ:

Mã:

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
          [B][COLOR=#ff0000]Range("A60000").End(xlUp).Offset(1).Resize(lRs, lCs).Value = arr[/COLOR][/B]
        Next
      End If
      .Close
    End With
  End If
End Sub

Sửa đoạn này:
Range("A60000").End(xlUp).Offset(1).Resize(lRs, lCs).Value = arr
Thành:
ActiveCell.Resize(lRs, lCs).Value = arr

sinhthanh1984 · 28/6/13

Thầy ndu96081631
giúp em tạo 1 button để chạy code với a. Cho tiện đó mà thầy.
Ah thầy ơi em có 1 việc riêng tư chút. Em muốn xin số điện thoại của thầy ạ.

ndu96081631 · 28/6/13

Ah... cũng xin nói thêm: Code của tôi là dữ phòng trường hợp trọng file Word có từ 2 Table trở lên. Nhưng bây giờ bạn lại 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
Thế thì sửa code thành vầy sẽ hay hơn:

Mã:

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

Bớt 1 vòng lập
------------------------------

sinhthanh1984 đã viết:
Thầyndu96081631
giúp em tạo 1 button để chạy code với a. Cho tiện đó mà thầy.
Ah thầy ơi em có 1 việc riêng tư chút. Em muốn xin số điện thoại của thầy ạ.

Bạn cứ việc dùng công cụ Drawing vẽ bất cứ hình gì trên bảng tính (hình vuông, hình tròn hay hình gì tuỳ ý)
Vẽ xong, cứ Click phải chuột vào hình vừa vẽ, chọn Assign Macro, chỉ đến GetWordTable rồi OK là được rồi
Từ giờ, nhấn vào hình đồng nghĩa là gọi code

sinhthanh1984 · 28/6/13

ndu96081631 đã viết:
Ah... cũng xin nói thêm: Code của tôi là dữ phòng trường hợp trọng file Word có từ 2 Table trở lên. Nhưng bây giờ bạn lại 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
Thế thì sửa code thành vầy sẽ hay hơn:

Mã:

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

Bớt 1 vòng lập

Thầy ơi! Thầy cứ để code trước đi. Em muốn Pates vào ô hiện hành để đề phòng trường hợp có 2 file dữ liệu nguồn thôi mà.

sinhthanh1984 · 29/6/13

Mình đã tạo được một button rồi. Không biết có đẹp không còn cách tạo nào mà button đẹp hơn ko? Anh chị em xem và góp ý với.

ndu96081631 · 29/6/13

sinhthanh1984 đã viết:
Rất mong thầy ndu96081631 "chỉ giáo"

Vậy là được rồi (mọi người cũng làm thế)
Ngoài ra cũng có thể dùng 1 hình vẽ bất kỳ để làm Button... Nói chung cũng không quan trọng gì lắm mấy vụ màu mè này vì đàng nào thì việc CODE CHẠY CHÍNH XÁC mới là cái ta cần quan tâm nhất

TrungChinhs · 29/6/13

sinhthanh1984 đã viết:
Mình đã tạo được một button rồi. Không biết có đẹp không còn cách tạo nào mà button đẹp hơn ko? Anh chị em xem và góp ý với.

Nói thật là button bạn vẽ không đẹp.
Bạn hãy quan sát button của Microsoft (chiều cao, chiều dài) mà bắt chước.

Chuyển dữ liệu từ Word sang Excel. (1 người xem)

Người dùng đang xem chủ đề này

Thành viên hoạt động

File đính kèm

Huyền thoại GPE

Thành viên hoạt động

Huyền thoại GPE

Thành viên mới

Huyền thoại GPE

Thành viên hoạt động

Thành viên hoạt động

Thành viên tích cực

Thành viên hoạt động

Thành viên hoạt động

Thành viên hoạt động

Thành viên hoạt động

Huyền thoại GPE

Thành viên hoạt động

Huyền thoại GPE

Thành viên hoạt động

Thành viên hoạt động

File đính kèm

Huyền thoại GPE

Thành viên tích cực

Đếm ngược thời gian