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

Mình có file word bảng đáp án và file excel bảng đáp án theo mẫu. Nhờ giúp đỡ tạo buttun chuyển bảng đáp án từ word sang ecxel theo mẫu dùm. Cám ơn

Mở tập tin DapanchamQM.xlsx -> nhấn tổ hợp Alt + F11 để vào VBE -> menu Insert -> Module -> dán code sau vào Module1 -> lưu lại tập tin với định dạng XLSM -> đặt 1 Button xuống sheet -> chọn macro DapAn

Sau khi nhấn Button thì chọn tập tin Word để lấy dữ liệu.

Option Explicit

Sub DapAn()
Const wdGoToLine = 3
Const wdParagraph = 4
Dim k As Long, c As Long, fname, text As String, result(), WordApp As Object, doc As Object, sel As Object, tabl As Object
'    xoa du lieu cu
    ThisWorkbook.Worksheets("Sheet3").Range("A2:K1000").ClearContents
'    mo chon tap tin Word
    fname = Application.GetOpenFilename("Word Files (*.doc;*.docx),*.doc;*.docx")
    If fname = False Then Exit Sub  ' khong chon thi ket thuc
'    mo server Word
    Set WordApp = CreateObject("Word.Application")
    Set doc = WordApp.documents.Open(fname) ' mo tap tin vua chon
    ReDim result(1 To doc.Tables.Count, 1 To 11)
'    duyet tung bang trong tap tin Word
    For k = 1 To doc.Tables.Count
        Set tabl = doc.Tables(k)
        tabl.Range.GoToPrevious(wdGoToLine).Select
        WordApp.Selection.Expand wdParagraph
        text = WordApp.Selection.text
        result(k, 1) = Trim(Mid(text, 1, Len(text) - 1))
        For c = 1 To 10
            text = tabl.cell(2, c).Range.text   ' Ma de
            result(k, c + 1) = Application.Clean(Trim(Mid(text, 1, Len(text) - 1))) ' cac dap an
        Next c
    Next k
'    nhap ket qua vao sheet
    ThisWorkbook.Worksheets("Sheet3").Range("A2").Resize(UBound(result, 1), UBound(result, 2)).Value = result
    WordApp.Quit
    Set doc = Nothing
    Set WordApp = Nothing
End Sub

Cám ơn Bạn rất nhiều, đúng theo yêu cầu rồi nhưng làm sao để cột mã đề chỉ là số trong dấu

1. Thêm ở đầu

Dim pos1 As Long, pos2 As Long

2.
Thay

result(k, 1) = Trim(Mid(text, 1, Len(text) - 1))

bằng

pos1 = InStr(1, text, "[")
If pos1 Then
    pos2 = InStr(pos1, text, "]")
    If pos2 = 0 Then pos2 = Len(text) - 1
    text = Mid(text, pos1 + 1, pos2 - pos1 - 1)
End If
result(k, 1) = CLng(text)

Rất cám ơn Bạn đã giúp đỡ. Mình nhờ bạn lần này nữa thôi: Dòng câu có thể thay đổi tùy theo số câu trong đề trắc nghiệm (chứ không cố định 10 câu). Phiền Bạn giúp đỡ thêm ạ

Sửa

ReDim result(1 To doc.Tables.Count, 1 To 10)

thành

ReDim result(1 To doc.Tables.Count, 1 To 1)

Sau

Set tabl = doc.Tables(k)

thì thêm 1 dòng

If UBound(result, 2) < tabl.Columns.Count + 1 Then ReDim Preserve result(1 To UBound(result, 1), 1 To tabl.Columns.Count + 1)

Sửa

For c = 1 To 10

thành

For c = 1 To tabl.Columns.Count

Khóa học SprinGO phù hợp

Khóa học Power PI – Ứng dung trong Nhân sự

TỔNG QUAN KHÓA HỌC: POWER BI CHO NGÀNH NHÂN SỰ Khóa học Power BI cho Nhân sự được thiết kế dành riêng cho các...

Xem khóa học