Mn ới cho e hỏi cách chuyển trắc nghiệm từ word sang excel vs ạaaaaaa

[Linhgggggggggg]

E muốn chuyển từ đáp án thế kia sang bảng như này ạ

 

[ngocbaovu]

Bạn đặt tiêu đề vậy nên mọi người không trả lời. Bài này dùng VBA nhé.

Sub CopyTracnghiem()
    Dim objWord As Word.Application
    Dim objDoc As Word.Document
    Dim RgStart, RgEnd, RgCopy As Word.Range
    Dim i As Integer
    Set objWord = New Word.Application
    With Application.FileDialog(msoFileDialogFilePicker)
        .Filters.Clear
        .Filters.Add "Word Documents", "*.*"
        If .Show = -1 Then
            Set objDoc = objWord.Documents.Open(.SelectedItems(1), ReadOnly:=True)
        Else
            Exit Sub
        End If
    End With
    ActiveSheet.Range("A2:E500").ClearContents
    For i = 2 To 500
    Set RgStart = objDoc.Content
    RgStart.Find.Execute "Câu " & i - 1
    Set RgEnd = objDoc.Content
        If Not RgEnd.Find.Execute("Câu " & i) Then
            Exit Sub
        End If
    Set RgCopy = objDoc.Range(RgStart.End, RgEnd.Start)
    ActiveSheet.Range("A" & i).Value = "Câu " & i - 1 & Trim(Split(RgCopy, "A.")(0))
    ActiveSheet.Range("B" & i).Value = "A. " & Trim(Split(Split(RgCopy, "A.")(1), "B.")(0))
    ActiveSheet.Range("C" & i).Value = "B. " & Trim(Split(Split(RgCopy, "B.")(1), "C.")(0))
    ActiveSheet.Range("D" & i).Value = "C. " & Trim(Split(Split(RgCopy, "C.")(1), "D.")(0))
    ActiveSheet.Range("E" & i).Value = "D. " & Trim(Split(RgCopy, "D.")(1))
    Next i
    objDoc.Close SaveChanges:=False
    objWord.Quit
End Sub

Code dùng đối tượng Word nên cần khai báo thư viện trong VBA. Code này đọc file word, tìm đoạn text giữa text "Câu x" và "Câu x+1" rồi tách thành các chuỗi con bằng cách tương tự.

 

[cantl]

Từ tên nick đến tiêu đề.
Từ ánh mắt đến trái tim.
Từ vội vã đến cẩu thả.
Há há há.