Chuyển đáp án từ file word sang excel

nguyencongtinh · 7/4/23

Mình có một file words chứa dữ liệu, trong đó có bảng đáp án của các mã đề tương ứng, mình muốn chuyển các đáp án từ words sang bảng tính excel theo mẫu. Mong các anh/chị viết giùm code VBA ạ. Cám ơn mọi người.

giaiphap · 7/4/23

Sử dụng Code này cho File Excel, việc kiểm tra dành cho bạn.

Mã:

Sub WordToExcel()
    Dim docFilename As Object, wordApp As Object
    Dim i As Integer, j As Integer, k As Integer
    On Error GoTo Thoat
    Dim FilePath, Arr(), iRow As Integer
    FilePath = Application.GetOpenFilename("Word Files (*.doc*), *.doc*")
    If FilePath <> False Then
        iRow = Sheet1.Range("A10000").End(xlUp).Row + 1
        Sheet1.Rows("2:" & iRow).Delete
        Set wordApp = CreateObject("Word.Application")
            Set docFilename = wordApp.documents.Open(FilePath)
            For i = 2 To docFilename.Tables.Count
                With docFilename.Tables(i)
                    If .Rows.Count > 1 Then
                        ReDim Arr(1 To .Columns.Count - 1, 1 To .Rows.Count)
                        For k = 2 To .Columns.Count
                            Arr(k - 1, 1) = Left(.cell(1, k), Len(.cell(1, k)) - 1)
                        Next k
                        For j = 2 To .Rows.Count
                            For k = 2 To .Columns.Count
                                Arr(k - 1, j) = Left(.cell(j, k), Len(.cell(j, k)) - 1)
                            Next k
                        Next j
                        iRow = Sheet1.Range("A10000").End(xlUp).Row + 1
                        Sheet1.Range("A" & iRow).Resize(.Columns.Count - 1, .Rows.Count).Value = Arr
                    End If
                End With
            Next i
            docFilename.Close True
            Set docFilename = Nothing
        Set wordApp = Nothing
        MsgBox "Da thuc hien xong", , "---GPE---"
    End If
    Exit Sub
Thoat:
        docFilename.Close False
        Set docFilename = Nothing
    Set wordApp = Nothing
    MsgBox "Da co loi xu ly", , "---GPE---"
End Sub

VetMini · 7/4/23

Chỉ có một file thì làm tay quách cho xong. Viết code còn cực hơn.

nguyencongtinh · 7/4/23

giaiphap đã viết:

Sử dụng Code này cho File Excel, việc kiểm tra dành cho bạn.

Mã:

Sub WordToExcel()
    Dim docFilename As Object, wordApp As Object
    Dim i As Integer, j As Integer, k As Integer
    On Error GoTo Thoat
    Dim FilePath, Arr(), iRow As Integer
    FilePath = Application.GetOpenFilename("Word Files (*.doc*), *.doc*")
    If FilePath <> False Then
        iRow = Sheet1.Range("A10000").End(xlUp).Row + 1
        Sheet1.Rows("2:" & iRow).Delete
        Set wordApp = CreateObject("Word.Application")
            Set docFilename = wordApp.documents.Open(FilePath)
            For i = 2 To docFilename.Tables.Count
                With docFilename.Tables(i)
                    If .Rows.Count > 1 Then
                        ReDim Arr(1 To .Columns.Count - 1, 1 To .Rows.Count)
                        For k = 2 To .Columns.Count
                            Arr(k - 1, 1) = Left(.cell(1, k), Len(.cell(1, k)) - 1)
                        Next k
                        For j = 2 To .Rows.Count
                            For k = 2 To .Columns.Count
                                Arr(k - 1, j) = Left(.cell(j, k), Len(.cell(j, k)) - 1)
                            Next k
                        Next j
                        iRow = Sheet1.Range("A10000").End(xlUp).Row + 1
                        Sheet1.Range("A" & iRow).Resize(.Columns.Count - 1, .Rows.Count).Value = Arr
                    End If
                End With
            Next i
            docFilename.Close True
            Set docFilename = Nothing
        Set wordApp = Nothing
        MsgBox "Da thuc hien xong", , "---GPE---"
    End If
    Exit Sub
Thoat:
        docFilename.Close False
        Set docFilename = Nothing
    Set wordApp = Nothing
    MsgBox "Da co loi xu ly", , "---GPE---"
End Sub

Quá chuẩn và quá nhanh. Cám ơn giaiphap!

nguyencongtinh · 11/4/23

giaiphap đã viết:

Sử dụng Code này cho File Excel, việc kiểm tra dành cho bạn.

Mã:

Sub WordToExcel()
    Dim docFilename As Object, wordApp As Object
    Dim i As Integer, j As Integer, k As Integer
    On Error GoTo Thoat
    Dim FilePath, Arr(), iRow As Integer
    FilePath = Application.GetOpenFilename("Word Files (*.doc*), *.doc*")
    If FilePath <> False Then
        iRow = Sheet1.Range("A10000").End(xlUp).Row + 1
        Sheet1.Rows("2:" & iRow).Delete
        Set wordApp = CreateObject("Word.Application")
            Set docFilename = wordApp.documents.Open(FilePath)
            For i = 2 To docFilename.Tables.Count
                With docFilename.Tables(i)
                    If .Rows.Count > 1 Then
                        ReDim Arr(1 To .Columns.Count - 1, 1 To .Rows.Count)
                        For k = 2 To .Columns.Count
                            Arr(k - 1, 1) = Left(.cell(1, k), Len(.cell(1, k)) - 1)
                        Next k
                        For j = 2 To .Rows.Count
                            For k = 2 To .Columns.Count
                                Arr(k - 1, j) = Left(.cell(j, k), Len(.cell(j, k)) - 1)
                            Next k
                        Next j
                        iRow = Sheet1.Range("A10000").End(xlUp).Row + 1
                        Sheet1.Range("A" & iRow).Resize(.Columns.Count - 1, .Rows.Count).Value = Arr
                    End If
                End With
            Next i
            docFilename.Close True
            Set docFilename = Nothing
        Set wordApp = Nothing
        MsgBox "Da thuc hien xong", , "---GPE---"
    End If
    Exit Sub
Thoat:
        docFilename.Close False
        Set docFilename = Nothing
    Set wordApp = Nothing
    MsgBox "Da co loi xu ly", , "---GPE---"
End Sub

Nhờ bạn giaiphap xử lý giúp, code chạy rất tốt nhưng có một vấn đề là: tất cả các ô dữ liệu sau xử lý đều thừa một khoảng trắng sau cùng.. Cám ơn bạn.

Maika8008 · 11/4/23

nguyencongtinh đã viết:
Nhờ bạn giaiphap xử lý giúp, code chạy rất tốt nhưng có một vấn đề là: tất cả các ô dữ liệu sau xử lý đều thừa một khoảng trắng sau cùng.. Cám ơn bạn.

Chỗ này: Arr(k - 1, 1) = Left(.cell(1, k), Len(.cell(1, k)) - 1) và chỗ này: Arr(k - 1, j) = Left(.cell(j, k), Len(.cell(j, k)) - 1) thêm hàm Trim thôi:
Arr(k - 1, 1) = Trim(Left(.cell(1, k), Len(.cell(1, k)) - 1))
Arr(k - 1, j) = Trim(Left(.cell(j, k), Len(.cell(j, k)) - 1))

nguyencongtinh · 11/4/23

Maika8008 đã viết:
Chỗ này: Arr(k - 1, 1) = Left(.cell(1, k), Len(.cell(1, k)) - 1) và chỗ này: Arr(k - 1, j) = Left(.cell(j, k), Len(.cell(j, k)) - 1) thêm hàm Trim thôi:
Arr(k - 1, 1) = Trim(Left(.cell(1, k), Len(.cell(1, k)) - 1))
Arr(k - 1, j) = Trim(Left(.cell(j, k), Len(.cell(j, k)) - 1))

Không được, bạn ạ. Kết quả như cũ, có thể đây là kí tự xuống dòng alt+enter ạ

Maika8008 · 11/4/23

nguyencongtinh đã viết:
Không được, bạn ạ. Kết quả như cũ, có thể đây là kí tự xuống dòng alt+enter ạ

Thế thì thay vì Trim thì bạn dùng Left kết hợp với Len(biểu thức) - 1 để cắt lấy phần muốn lấy xem.

nguyencongtinh · 12/4/23

giaiphap đã viết:

Sử dụng Code này cho File Excel, việc kiểm tra dành cho bạn.

Mã:

Sub WordToExcel()
    Dim docFilename As Object, wordApp As Object
    Dim i As Integer, j As Integer, k As Integer
    On Error GoTo Thoat
    Dim FilePath, Arr(), iRow As Integer
    FilePath = Application.GetOpenFilename("Word Files (*.doc*), *.doc*")
    If FilePath <> False Then
        iRow = Sheet1.Range("A10000").End(xlUp).Row + 1
        Sheet1.Rows("2:" & iRow).Delete
        Set wordApp = CreateObject("Word.Application")
            Set docFilename = wordApp.documents.Open(FilePath)
            For i = 2 To docFilename.Tables.Count
                With docFilename.Tables(i)
                    If .Rows.Count > 1 Then
                        ReDim Arr(1 To .Columns.Count - 1, 1 To .Rows.Count)
                        For k = 2 To .Columns.Count
                            Arr(k - 1, 1) = Left(.cell(1, k), Len(.cell(1, k)) - 1)
                        Next k
                        For j = 2 To .Rows.Count
                            For k = 2 To .Columns.Count
                                Arr(k - 1, j) = Left(.cell(j, k), Len(.cell(j, k)) - 1)
                            Next k
                        Next j
                        iRow = Sheet1.Range("A10000").End(xlUp).Row + 1
                        Sheet1.Range("A" & iRow).Resize(.Columns.Count - 1, .Rows.Count).Value = Arr
                    End If
                End With
            Next i
            docFilename.Close True
            Set docFilename = Nothing
        Set wordApp = Nothing
        MsgBox "Da thuc hien xong", , "---GPE---"
    End If
    Exit Sub
Thoat:
        docFilename.Close False
        Set docFilename = Nothing
    Set wordApp = Nothing
    MsgBox "Da co loi xu ly", , "---GPE---"
End Sub

Mọi người cho biết, tại sao code này viết trong *.xlsm thì chạy còn trong *.xlam lại không nhận được kết quả, nó vẫn báo Da thuc hien xong, trang tính vẫn "trắng tinh" ạ.

giaiphap · 13/4/23

nguyencongtinh đã viết:
Mọi người cho biết, tại sao code này viết trong *.xlsm thì chạy còn trong *.xlam lại không nhận được kết quả, nó vẫn báo Da thuc hien xong, trang tính vẫn "trắng tinh" ạ.

Thay chổ

Mã:

Sheet1.Range("A" & iRow).Resize(.Columns.Count - 1, .Rows.Count).Value = Arr

thành

Mã:

Selection.Resize(.Columns.Count - 1, .Rows.Count).Value = Arr

nguyencongtinh · 13/4/23

giaiphap đã viết:
Thay chổ

Mã:

Sheet1.Range("A" & iRow).Resize(.Columns.Count - 1, .Rows.Count).Value = Arr

thành

Mã:

Selection.Resize(.Columns.Count - 1, .Rows.Count).Value = Arr

Nếu thay theo như bạn thì code chạy nhưng có 2 vấn đề:
1. Dữ liệu chỉ được 1 phần. VD file words có 12 mã đề thì code chỉ cho ra 5 mã.
2. Dữ liệu xuất ra lại phụ thuộc vào vị trí mà ô đang được chọn, không phải bắt đầu từ ô A2 nữa
Mong bạn sửa giúp.

giaiphap · 13/4/23

nguyencongtinh đã viết:
Nếu thay theo như bạn thì code chạy nhưng có 2 vấn đề:
1. Dữ liệu chỉ được 1 phần. VD file words có 12 mã đề thì code chỉ cho ra 5 mã.
2. Dữ liệu xuất ra lại phụ thuộc vào vị trí mà ô đang được chọn, không phải bắt đầu từ ô A2 nữa
Mong bạn sửa giúp.

Thử sửa lại thế này xem sao, chổ

Mã:

        Row = Sheet1.Range("A10000").End(xlUp).Row + 1
        Sheet1.Rows("2:" & iRow).Delete

sửa thành

Mã:

        Row =ActiveSheet.Range("A10000").End(xlUp).Row + 1
        ActiveSheet.Rows("2:" & iRow).Delete

Chổ

Mã:

      iRow = Sheet1.Range("A10000").End(xlUp).Row + 1
      Sheet1.Range("A" & iRow).Resize(.Columns.Count - 1, .Rows.Count).Value = Arr

sửa thành

Mã:

      iRow =ActiveSheet.Range("A10000").End(xlUp).Row + 1
     ActiveSheet.Range("A" & iRow).Resize(.Columns.Count - 1, .Rows.Count).Value = Arr

nguyencongtinh · 14/4/23

giaiphap đã viết:

Thử sửa lại thế này xem sao, chổ

Mã:

        Row = Sheet1.Range("A10000").End(xlUp).Row + 1
        Sheet1.Rows("2:" & iRow).Delete

sửa thành

Mã:

        Row =ActiveSheet.Range("A10000").End(xlUp).Row + 1
        ActiveSheet.Rows("2:" & iRow).Delete

Chổ

Mã:

      iRow = Sheet1.Range("A10000").End(xlUp).Row + 1
      Sheet1.Range("A" & iRow).Resize(.Columns.Count - 1, .Rows.Count).Value = Arr

sửa thành

Mã:

      iRow =ActiveSheet.Range("A10000").End(xlUp).Row + 1
     ActiveSheet.Range("A" & iRow).Resize(.Columns.Count - 1, .Rows.Count).Value = Arr

Cám ơn nhiều. Còn một vấn đề cuối, mình muốn thêm 1 đoạn code để thêm thứ tự câu, mình viết trong *xlsm thì được, nhưng trong *xlam thì không được. Bạn sửa giúp ạ.

giaiphap · 14/4/23

nguyencongtinh đã viết:
Cám ơn nhiều. Còn một vấn đề cuối, mình muốn thêm 1 đoạn code để thêm thứ tự câu, mình viết trong *xlsm thì được, nhưng trong *xlam thì không được. Bạn sửa giúp ạ.

Chổ cần thêm sửa lại như sau:

Mã:

'Doan nay them de dien thu tu cau
    Dim currentRow, lastColumn As Integer
    With ActiveSheet
        .Range("A1") = "Câu"
        .Range("B1").Select
        currentRow = ActiveCell.Row
        lastColumn = .Cells(2, Columns.Count).End(xlToLeft).Column
        For i = 2 To lastColumn
            .Cells(currentRow, i).Value = i - 1
        Next i      'Het doan them
        MsgBox "Da thuc hien xong", , "---GPE---"
    End With

Chuyển đáp án từ file word sang excel

nguyencongtinh

Thành viên mới

File đính kèm

giaiphap

==(^o^)==

VetMini

Ăn cùng góc phố

nguyencongtinh

Thành viên mới

nguyencongtinh

Thành viên mới

Maika8008

Thành viên gạo cội

nguyencongtinh

Thành viên mới

Maika8008

Thành viên gạo cội

nguyencongtinh

Thành viên mới

giaiphap

==(^o^)==

nguyencongtinh

Thành viên mới

giaiphap

==(^o^)==

nguyencongtinh

Thành viên mới

File đính kèm

giaiphap

==(^o^)==

Bài viết mới nhất

Thành viên có số lượng bài viết cao nhất tháng

Thành viên có điểm tương tác cao nhất tháng