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

daocuongnbk

Thành viên chính thức
Tham gia ngày
27 Tháng mười hai 2009
Bài viết
76
Được thích
6
Điểm
670
Tuổi
51
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
 

File đính kèm

batman1

Thành viên gạo cội
Tham gia ngày
8 Tháng chín 2014
Bài viết
3,562
Được thích
5,444
Điểm
560
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.
Mã:
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
 

File đính kèm

daocuongnbk

Thành viên chính thức
Tham gia ngày
27 Tháng mười hai 2009
Bài viết
76
Được thích
6
Điểm
670
Tuổi
51
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.
Mã:
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 [ ]
 

batman1

Thành viên gạo cội
Tham gia ngày
8 Tháng chín 2014
Bài viết
3,562
Được thích
5,444
Điểm
560
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
Mã:
Dim pos1 As Long, pos2 As Long
2.
Thay
Mã:
result(k, 1) = Trim(Mid(text, 1, Len(text) - 1))
bằng
Mã:
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)
 

daocuongnbk

Thành viên chính thức
Tham gia ngày
27 Tháng mười hai 2009
Bài viết
76
Được thích
6
Điểm
670
Tuổi
51
1. Thêm ở đầu
Mã:
Dim pos1 As Long, pos2 As Long
2.
Thay
Mã:
result(k, 1) = Trim(Mid(text, 1, Len(text) - 1))
bằng
Mã:
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 ạ
 

batman1

Thành viên gạo cội
Tham gia ngày
8 Tháng chín 2014
Bài viết
3,562
Được thích
5,444
Điểm
560
Sửa
Mã:
ReDim result(1 To doc.Tables.Count, 1 To 10)
thành
Mã:
ReDim result(1 To doc.Tables.Count, 1 To 1)
Sau
Mã:
Set tabl = doc.Tables(k)
thì thêm 1 dòng
Mã:
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
Mã:
For c = 1 To 10
thành
Mã:
For c = 1 To tabl.Columns.Count
 

daocuongnbk

Thành viên chính thức
Tham gia ngày
27 Tháng mười hai 2009
Bài viết
76
Được thích
6
Điểm
670
Tuổi
51
Sửa
Mã:
ReDim result(1 To doc.Tables.Count, 1 To 10)
thành
Mã:
ReDim result(1 To doc.Tables.Count, 1 To 1)
Sau
Mã:
Set tabl = doc.Tables(k)
thì thêm 1 dòng
Mã:
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
Mã:
For c = 1 To 10
thành
Mã:
For c = 1 To tabl.Columns.Count
Cám ơn Bạn rất nhiều
 
Top Bottom