Xin các bác cách chuyển câu hỏi trắc nghiệm word sang excel ạ

Liên hệ QC
Tôi tuân thủ nội quy khi đăng bài
Có
Một cách khác có thể tham khảo dùng VBA của Word, nhấn tổ hợp phím Ctrl+Alt+Q để xem kết quả.
 

File đính kèm

  • XLCHTN.zip
    24.5 KB · Đọc: 39
giaiphap đã viết:
Một cách khác có thể tham khảo dùng VBA của Word, nhấn tổ hợp phím Ctrl+Alt+Q để xem kết quả.
Nhấp chuột vào đây để mở rộng...
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 đỡ!
 

File đính kèm

  • De TN.rar
    31.3 KB · Đọc: 5
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 đỡ!
Nhấp chuột vào đây để mở rộng...
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
 
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
Nhấp chuột vào đây để mở rộng...
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!
 

File đính kèm

  • De TN.rar
    24.8 KB · Đọc: 4
  • loi.jpg
    loi.jpg
    165.8 KB · Đọc: 21
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!
Nhấp chuột vào đây để mở rộng...
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.
 

File đính kèm

  • De TN.zip
    29.5 KB · Đọc: 14
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.
Nhấp chuột vào đây để mở rộng...
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!!!
 
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é.
Nhấp chuột vào đây để mở rộng...
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 ạ
 
Bạn phải đăng nhập hoặc đăng ký để trả lời bài viết tại đây.
Web KT

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

LuuAnh980
  • Question
Code lấy dữ liệu từ 3 file con.
2
Trả lời
36
Đọc
444
hoangtran1176
hoangtran1176
S
  • Question
Không lấy đủ dữ liệu bằng kết nối ADO
Trả lời
16
Đọc
284
shnhatha221108
S
M
Bảng Pivot ko tự update theo dữ liệu và còn cộng thiếu số liệu.
Trả lời
5
Đọc
48
Manofwar77
M
emlat3
Đặt màu xen kẽ các dòng theo ký tự
Trả lời
0
Đọc
18
emlat3
emlat3
A
[Góc giúp đỡ] Tìm kiếm, lọc và lấy dữ liệu từ nhiều file Word cấu trúc giống nhau vào 1 file excel mẫu
Trả lời
11
Đọc
220
Hoàng Tuấn 868
H
Xem thêm…

Facebook

Giaiphapexcel.com

Group

DIỄN ĐÀN GIẢI PHÁP EXCEL Group 1
DIỄN ĐÀN GIẢI PHÁP EXCEL Group 2

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

Back
Top Bottom