Xin các bác cách chuyển câu hỏi trắc nghiệm word sang excel ạ (4 người xem)

giaiphap · 7/3/23

Một cách khác có thể tham khảo dùng VBA của Word, nhấn tổ hợp phím Ctrl+Alt+Q để xem kết quả.

ơkgk · 16/4/23

clien172 đã viết:
Em cảm ơn bác , EM hiểu file của bác rồi ạ, file của bác rất hay ạ, tổng quát luôn ạ.

Bác ơi cho em hỏi xíu, em đã áp code nhưng lúc chạy máy cứ báo lỗi ở dòng 9 With Sheets("Word") là tại sao vậy ạ

bebo021999 · 17/4/23

ơkgk đã viết:
Bác ơi cho em hỏi xíu, em đã áp code nhưng lúc chạy máy cứ báo lỗi ở dòng 9 With Sheets("Word") là tại sao vậy ạ

File của bạn có sheet "Word" hay không?
Nếu là sheet khác thì thay tên sheet đó vô nhé

thienthanthangnam · 7/10/23

giaiphap đã viết:
Một cách khác có thể tham khảo dùng VBA của Word, nhấn tổ hợp phím Ctrl+Alt+Q để xem kết quả.

File của bác rất hay, nhưng nếu có thể được, mong bác giúp thêm một việc nữa cho hoàn chỉnh a.
Cụ thể, trong file Word là các câu hỏi với 4 phương án A, B, C, D. Trong đó có 1 phương án đúng (được đánh dấu). Làm cách nào để xuất được các đáp án đúng này vào 1 cột được không ạ (Ghi vào cột F chẳng hạn)?
E gửi file minh hoạ đính kèm. Mong bác giúp đỡ!

giaiphap · 7/10/23

thienthanthangnam đã viết:
File của bác rất hay, nhưng nếu có thể được, mong bác giúp thêm một việc nữa cho hoàn chỉnh a.
Cụ thể, trong file Word là các câu hỏi với 4 phương án A, B, C, D. Trong đó có 1 phương án đúng (được đánh dấu). Làm cách nào để xuất được các đáp án đúng này vào 1 cột được không ạ (Ghi vào cột F chẳng hạn)?
E gửi file minh hoạ đính kèm. Mong bác giúp đỡ!

Thay đổi tất cả code như sau:

Mã:

Option Explicit
Private Arr()
Sub RunCode()
    Call LayDapAn
    Call XuLy
End Sub
Private Sub LayDapAn()
    Dim i As Long
    Selection.HomeKey Unit:=wdStory
    With Selection.Find
        .ClearFormatting
        .Highlight = True
        .Text = ""
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindContinue
        .Format = True
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
        i = 0
        Do While .Execute
            i = i + 1
           ReDim Preserve Arr(1 To i)
           Arr(i) = Replace(Selection.Text, ".", "")
        Loop
    End With
End Sub

Private Sub FindText(FindWhat As String, ReplaceWith As String)
    Selection.HomeKey Unit:=wdStory
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = FindWhat
        .Replacement.Text = ReplaceWith
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchAllWordForms = False
        .MatchSoundsLike = False
        .MatchWildcards = True
        .Execute Replace:=wdReplaceAll
    End With
End Sub
Private Sub XuLy()
    Call FindText("^9^9", "^9")
    Call FindText("^13^9A", "^9A")
    Call FindText("^13A.", "^9A.")
    Call FindText("^13^9B", "^9B")
    Call FindText("^13B.", "^9B.")
    Call FindText("^13^9C", "^9C")
    Call FindText("^13C.", "^9C.")
    Call FindText("^13^9D", "^9D")
    Call FindText("^13D.", "^9D.")
    Call CreateExcel
    'MsgBox "Da xu ly xong"
End Sub
Private Sub CreateExcel()
    Dim myExcel As Object
    Dim myWb As Object, MyWs As Object
    Selection.WholeStory
    Selection.Copy
    Set myExcel = CreateObject("Excel.Application")
    myExcel.Visible = True
    Set myWb = myExcel.Workbooks.Add
    Application.DisplayAlerts = False
    Set MyWs = myWb.Sheets(1)
    MyWs.Cells(1, 1) = "Câu ho" & ChrW(777) & "i"
    MyWs.Cells(1, 2) = ChrW(272) & "a" & ChrW(769) & "p a" & ChrW(769) & "n A"
    MyWs.Cells(1, 3) = ChrW(272) & "a" & ChrW(769) & "p a" & ChrW(769) & "n B"
    MyWs.Cells(1, 4) = ChrW(272) & "a" & ChrW(769) & "p a" & ChrW(769) & "n C"
    MyWs.Cells(1, 5) = ChrW(272) & "a" & ChrW(769) & "p a" & ChrW(769) & "n D"
    MyWs.Cells(1, 6) = ChrW(272) & "áp án " & ChrW(273) & "úng"
    MyWs.Cells(2, 1).Select
    MyWs.PasteSpecial Format:="HTML", Link:=False, DisplayAsIcon:=False, NoHTMLFormatting:=True
    MyWs.Range("A1:F1").Font.Bold = True
    MyWs.Columns("A:F").EntireColumn.AutoFit
    MyWs.Range("F2").Resize(UBound(Arr)).Value = myExcel.WorksheetFunction.Transpose(Arr)
    Application.DisplayAlerts = True
    MyWs.Cells(2, 1).Select
    Set myWb = Nothing
    Set myExcel = Nothing
End Sub

thienthanthangnam · 7/10/23

Cảm ơn bác đã giúp đỡ ạ.

thienthanthangnam · 7/10/23

giaiphap đã viết:

Thay đổi tất cả code như sau:

Mã:

Option Explicit
Private Arr()
Sub RunCode()
    Call LayDapAn
    Call XuLy
End Sub
Private Sub LayDapAn()
    Dim i As Long
    Selection.HomeKey Unit:=wdStory
    With Selection.Find
        .ClearFormatting
        .Highlight = True
        .Text = ""
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindContinue
        .Format = True
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
        i = 0
        Do While .Execute
            i = i + 1
           ReDim Preserve Arr(1 To i)
           Arr(i) = Replace(Selection.Text, ".", "")
        Loop
    End With
End Sub

Private Sub FindText(FindWhat As String, ReplaceWith As String)
    Selection.HomeKey Unit:=wdStory
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = FindWhat
        .Replacement.Text = ReplaceWith
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchAllWordForms = False
        .MatchSoundsLike = False
        .MatchWildcards = True
        .Execute Replace:=wdReplaceAll
    End With
End Sub
Private Sub XuLy()
    Call FindText("^9^9", "^9")
    Call FindText("^13^9A", "^9A")
    Call FindText("^13A.", "^9A.")
    Call FindText("^13^9B", "^9B")
    Call FindText("^13B.", "^9B.")
    Call FindText("^13^9C", "^9C")
    Call FindText("^13C.", "^9C.")
    Call FindText("^13^9D", "^9D")
    Call FindText("^13D.", "^9D.")
    Call CreateExcel
    'MsgBox "Da xu ly xong"
End Sub
Private Sub CreateExcel()
    Dim myExcel As Object
    Dim myWb As Object, MyWs As Object
    Selection.WholeStory
    Selection.Copy
    Set myExcel = CreateObject("Excel.Application")
    myExcel.Visible = True
    Set myWb = myExcel.Workbooks.Add
    Application.DisplayAlerts = False
    Set MyWs = myWb.Sheets(1)
    MyWs.Cells(1, 1) = "Câu ho" & ChrW(777) & "i"
    MyWs.Cells(1, 2) = ChrW(272) & "a" & ChrW(769) & "p a" & ChrW(769) & "n A"
    MyWs.Cells(1, 3) = ChrW(272) & "a" & ChrW(769) & "p a" & ChrW(769) & "n B"
    MyWs.Cells(1, 4) = ChrW(272) & "a" & ChrW(769) & "p a" & ChrW(769) & "n C"
    MyWs.Cells(1, 5) = ChrW(272) & "a" & ChrW(769) & "p a" & ChrW(769) & "n D"
    MyWs.Cells(1, 6) = ChrW(272) & "áp án " & ChrW(273) & "úng"
    MyWs.Cells(2, 1).Select
    MyWs.PasteSpecial Format:="HTML", Link:=False, DisplayAsIcon:=False, NoHTMLFormatting:=True
    MyWs.Range("A1:F1").Font.Bold = True
    MyWs.Columns("A:F").EntireColumn.AutoFit
    MyWs.Range("F2").Resize(UBound(Arr)).Value = myExcel.WorksheetFunction.Transpose(Arr)
    Application.DisplayAlerts = True
    MyWs.Cells(2, 1).Select
    Set myWb = Nothing
    Set myExcel = Nothing
End Sub

Cảm ơn bác đã giúp đỡ.
Em nhập code bác gửi, khi chạy báo lỗi. Em không biết xử lí sao nữa.
Nhân tiện đây, nhờ bác giúp luôn một nút lệnh vào file word (đính kèm) để khi chạy cho tiện. Em mày mò google cả buổi mà không được ạ!
Cảm ơn bác nhiều!

giaiphap · 7/10/23

thienthanthangnam đã viết:
Cảm ơn bác đã giúp đỡ.
Em nhập code bác gửi, khi chạy báo lỗi. Em không biết xử lí sao nữa.
Nhân tiện đây, nhờ bác giúp luôn một nút lệnh vào file word (đính kèm) để khi chạy cho tiện. Em mày mò google cả buổi mà không được ạ!
Cảm ơn bác nhiều!

Tui ghi rất rõ là "thay tất cả code" trong khi bạn chỉ thay có một phần, vã lại file bạn gửi ở #24 và #27 lại khác nhau, file #27 có nút lệnh dẫn đến câu hỏi trắc nghiệm bị xuống một dòng. Bạn xem lại file.

thienthanthangnam · 7/10/23

giaiphap đã viết:
Tui ghi rất rõ là "thay tất cả code" trong khi bạn chỉ thay có một phần, vã lại file bạn gửi ở #24 và #27 lại khác nhau, file #27 có nút lệnh dẫn đến câu hỏi trắc nghiệm bị xuống một dòng. Bạn xem lại file.

Hii, bác thông cảm! Tại e không thành thạo.
Giờ ổn quá rồi. Cảm ơn bác nhiều!!!

Maika8008 · 8/10/23

thienthanthangnam đã viết:
Hii, bác thông cảm! Tại e không thành thạo.
Giờ ổn quá rồi. Cảm ơn bác nhiều!!!

Không phải do không thành thạo mà là do tính thiếu cẩn thận.

quangtribui2005 · 25/12/23

Hoàng Tuấn 868 đã viết:
Bạn copy toàn bộ các trang word, dán vào sheet Nguon từ ô A1 theo định dạng Match Destination Formatiing (M), sau đó bấm vào nút màu xanh bên sheet Dich rồi chờ một chút là xong.
File dưới đây là kết quả mình đã thử với file word bạn đính kèm. Bạn kiểm tra lại nhé.

anh ơi cho e hỏi nút màu xanh bên sheet là phần nào vậy ạ E cảm ơn ạ

Xin các bác cách chuyển câu hỏi trắc nghiệm word sang excel ạ (4 người xem)

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

giaiphap

==(^o^)==

File đính kèm

ơkgk

Thành viên mới

bebo021999

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

thienthanthangnam

Thành viên mới

File đính kèm

giaiphap

==(^o^)==

thienthanthangnam

Thành viên mới

thienthanthangnam

Thành viên mới

File đính kèm

giaiphap

==(^o^)==

File đính kèm

thienthanthangnam

Thành viên mới

Maika8008

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

quangtribui2005

Thành viên mới

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

Đếm ngược thời gian