Lọc dữ liệu từ file word sang excel

[mynguyenanh]

Em có 1 file word giấy báo thi, Em muốn lọc những học sinh có cùng địa điểm thi sang 1 file excel. Mong các ace của GPE giúp em với.

 

[Hoàng Tuấn 868]

Em có 1 file word giấy báo thi, Em muốn lọc những học sinh có cùng địa điểm thi sang 1 file excel. Mong các ace của GPE giúp em với.

Không biết file dưới đây có đúng ý bạn không? (Xem sheet3)

 

[giaiphap]

Em có 1 file word giấy báo thi, Em muốn lọc những học sinh có cùng địa điểm thi sang 1 file excel. Mong các ace của GPE giúp em với.

thử code này xem sao? (Mới nghiên cứu tới VBA của Word nên viết thử code)

Public Sub GPE()
    Dim tb As Table, Dic As Object, s As String
    Dim NameArr(), SchoolsArr(), i As Integer, j As Integer
    Dim myExcel As Object, myWb As Object, myWh As Object
    Dim ArrList(), k As Integer, h As Integer

    Set Dic = CreateObject("Scripting.Dictionary")
    i = 0
    For Each tb In ThisDocument.Tables
        If tb.Rows.Count = 17 Then
            i = i + 1
            s = tb.Cell(1, 1).Range.Text
            ReDim Preserve NameArr(1 To i): ReDim Preserve SchoolsArr(1 To i)
            NameArr(i) = Mid(s, 18, Len(s) - 18)
            s = tb.Cell(9, 1).Range.Text
            SchoolsArr(i) = Mid(s, 19, Len(s) - 19)
        End If
    Next tb
   
    If i = 0 Then Exit Sub
    Set myExcel = CreateObject("Excel.Application")
    myExcel.Application.Visible = True
    Set myWb = myExcel.Workbooks.Add
    For j = 1 To i
        If Not Dic.Exists(SchoolsArr(j)) Then
            Dic.Add SchoolsArr(j), SchoolsArr(j)
            h = 0: Erase ArrList: ReDim ArrList(1 To i, 1 To 2)
            For k = j To i
                If SchoolsArr(j) = SchoolsArr(k) Then
                    h = h + 1
                    ArrList(h, 1) = h
                    ArrList(h, 2) = NameArr(k)
                End If
            Next k
            If j <> 1 Then myWb.Worksheets.Add
            Set myWh = myWb.ActiveSheet
            myWh.Range("A2") = "STT": myWh.Range("B2") = "HO VA TEN"
            myWh.Range("A3").Resize(h, 2) = ArrList
            myWh.Columns("A:B").EntireColumn.AutoFit
            myWh.Range("A2").Resize(h + 1, 2).Borders.LineStyle = 1
            myWh.Range("A1") = SchoolsArr(j)
        End If
    Next j
    Set Dic = Nothing
    Set myExcel = Nothing
    Set myWb = Nothing
    Set myWh = Nothing
End Sub

 

[mynguyenanh]

Không biết file dưới đây có đúng ý bạn không? (Xem sheet3)

Chuẩn rồi bạn ơi, mình xin cảm ơn bạn rất nhiều

 

[babyheomoi]

thử code này xem sao? (Mới nghiên cứu tới VBA của Word nên viết thử code)

Public Sub GPE()
    Dim tb As Table, Dic As Object, s As String
    Dim NameArr(), SchoolsArr(), i As Integer, j As Integer
    Dim myExcel As Object, myWb As Object, myWh As Object
    Dim ArrList(), k As Integer, h As Integer

    Set Dic = CreateObject("Scripting.Dictionary")
    i = 0
    For Each tb In ThisDocument.Tables
        If tb.Rows.Count = 17 Then
            i = i + 1
            s = tb.Cell(1, 1).Range.Text
            ReDim Preserve NameArr(1 To i): ReDim Preserve SchoolsArr(1 To i)
            NameArr(i) = Mid(s, 18, Len(s) - 18)
            s = tb.Cell(9, 1).Range.Text
            SchoolsArr(i) = Mid(s, 19, Len(s) - 19)
        End If
    Next tb
  
    If i = 0 Then Exit Sub
    Set myExcel = CreateObject("Excel.Application")
    myExcel.Application.Visible = True
    Set myWb = myExcel.Workbooks.Add
    For j = 1 To i
        If Not Dic.Exists(SchoolsArr(j)) Then
            Dic.Add SchoolsArr(j), SchoolsArr(j)
            h = 0: Erase ArrList: ReDim ArrList(1 To i, 1 To 2)
            For k = j To i
                If SchoolsArr(j) = SchoolsArr(k) Then
                    h = h + 1
                    ArrList(h, 1) = h
                    ArrList(h, 2) = NameArr(k)
                End If
            Next k
            If j <> 1 Then myWb.Worksheets.Add
            Set myWh = myWb.ActiveSheet
            myWh.Range("A2") = "STT": myWh.Range("B2") = "HO VA TEN"
            myWh.Range("A3").Resize(h, 2) = ArrList
            myWh.Columns("A:B").EntireColumn.AutoFit
            myWh.Range("A2").Resize(h + 1, 2).Borders.LineStyle = 1
            myWh.Range("A1") = SchoolsArr(j)
        End If
    Next j
    Set Dic = Nothing
    Set myExcel = Nothing
    Set myWb = Nothing
    Set myWh = Nothing
End Sub

Quá dữ! Anh có ít tài liệu vba word không cho em học cái ạ!

 

[giaiphap]

Quá dữ! Anh có ít tài liệu vba word không cho em học cái ạ!

Tôi chủ yếu lá tìm từ Google thôi bạn, còn bạn muốn tìm hiều thì tài liệu tiếng anh đây.