Code lấy từ khóa từ Word sang excel bị thiếu

vc_đi chơi

Thành viên chính thức
Tham gia ngày
21 Tháng chín 2019
Bài viết
69
Được thích
8
Điểm
20
Tuổi
29
Thưa các bác và các bạn.
Tôi có sử dụng đoạn code, phím chạy code là (Ctrl + Shift + W) để lấy từ khóa từ file Word sang file excel chứa trong cùng một foder
Các từ khóa trong Word được bôi đỏ mã màu RGB (255, 0, 0)
Khi mở file Excel và chạy code bằng phím tắt nói trên thì các từ khóa được lấy sang cột B của sheet Data, nhưng code lại không lấy được hết từ khóa trong file word có tên là (File_Mau) (như hình tôi đăng)
Nhờ các các bạn giúp tôi để lấy được từ khóa đầy đủ từ Word (File_Mau) sang cột B của sheet (Data) trong file excel.
Xin sự giúp đỡ từ các bác, mong hồi âm, xin cảm ơn.
1/ hình thứ nhất: file word ban đầu
2/ hình thứ hai: từ khóa được lấy sang file excel khi chạy code
3/ hình thứ 3: khi chạy code sẽ xuất 1 file word mới (có tên là "biên bản hiện trường") ứng với tên được điền trong sheet (Trang chu), các từ khóa bị thiếu chưa được lấy trong file word (File_Mau) xuất ra file word mới (biên bản hiện trường) vẫn còn màu đỏ.
Tôi có đính kèm file ở dưới, file excel và word đều trong một foder, khi chạy code cũng phải để trong cùng một foder
View attachment 225561View attachment 225562View attachment 225563
Bài đã được tự động gộp:

file Word.png

Key duoc lay.png

Tu khoa con thieu.png
 

File đính kèm

Lần chỉnh sửa cuối:

LamNA

Thành viên tích cực
Tham gia ngày
3 Tháng sáu 2014
Bài viết
880
Được thích
696
Điểm
560
Nơi ở
Sóc Trăng
Thưa các bác và các bạn.
Tối có sử dụng đoạn code, phím chạy code là (Ctrl + Shift + W) để lấy từ khóa từ file Word sang excel chứa trong cùng một foder
Các từ khóa trong Word được bôi đỏ mã màu RGB (255, 0, 0)
Khi mở file Excel và chạy code bằng phím tắt nói trên thì các từ khóa được lấy sang cột B của sheet Data, nhưng code lại không lấy được hết từ khóa (như hình tôi đăng)
Xin sự giúp đỡ từ các bác, mong hồi âm, xin cảm ơn.
1/ hình thứ nhất: file word ban đầu
2/ hình thứ hai: từ khóa được lấy sang file excel
3/ hình thứ 3: khi chạy code sẽ xuất 1 file word ứng với tên được điền trong sheet Trang chủ, các từ khóa bị thiếu chưa được lấy trong file xuất ra vẫn còn màu đỏ.
View attachment 225561View attachment 225562View attachment 225563
Bài đã được tự động gộp:

View attachment 225564

View attachment 225565

View attachment 225566
Góp ý:
bạn gửi hình thì anh chị diễn đàn chỉ nhìn thôi và chắc sẽ không ai hỗ trợ được khi bạn không có file mẫu đính kèm.
 

vc_đi chơi

Thành viên chính thức
Tham gia ngày
21 Tháng chín 2019
Bài viết
69
Được thích
8
Điểm
20
Tuổi
29
Lần chỉnh sửa cuối:

batman1

Thành viên gắn bó
Tham gia ngày
8 Tháng chín 2014
Bài viết
2,342
Được thích
3,559
Điểm
560
Tôi có sử dụng đoạn code, phím chạy code là (Ctrl + Shift + W) để lấy từ khóa từ file Word sang file excel chứa trong cùng một foder
Các từ khóa trong Word được bôi đỏ mã màu RGB (255, 0, 0)
Khi mở file Excel và chạy code bằng phím tắt nói trên thì các từ khóa được lấy sang cột B của sheet Data, nhưng code lại không lấy được hết từ khóa trong file word có tên là (File_Mau) (như hình tôi đăng)
Trong Sub ChuongTrinh của bạn có gọi ImportWord và KeyDaTa. Tôi ngại đọc code của người khác nên không dò xem chúng có cần thiết hay không. Nếu chúng còn làm gì đó thì bạn tự thêm vào.

Code không kiểm tra mầu đỏ hay mầu gì. Code coi các KEY có dạng [gì đó]

Sub ChuongTrinh của tôi chỉ làm một việc là lấy các KEY từ Word vào cột B của sheet Data.

Mảng Arr tôi khai báo cho max là 10 000 key
Mã:
Sub ChuongTrinh()
Dim Arr(), count As Long, text As String, wordApp As Object, wordDoc As Object, wordSelection As Object, fso As Object
    Application.ScreenUpdating = False
    '''''Kiem tra su ton tai cua File_Mau. Neu khong thay thi Msgbox thong bao va thoat khoi chuong trinh
    With CreateObject("Scripting.FileSystemObject")
        If .FileExists(ThisWorkbook.Path & "\" & "File_Mau.doc") = False Then
            MsgBox "Khong co tap tin File_Mau.doc"
            Exit Sub
        End If
    End With
    Sheets("DaTa").Range("B3:B10000").ClearContents
    ReDim Arr(1 To 10000, 1 To 1)
    Set wordApp = CreateObject("Word.Application")
    Set wordDoc = wordApp.Documents.Open(ThisWorkbook.Path & "\File_Mau.doc")
    Set wordSelection = wordApp.Selection
    With wordSelection.Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .text = "\[*\]"
        .MatchWildcards = True
        Do While .Execute
            count = count + 1
            Arr(count, 1) = Mid(wordSelection.text, 2, Len(wordSelection.text) - 2)
        Loop
    End With
    If count Then ThisWorkbook.Worksheets("Data").Range("B3").Resize(count).Value = Arr
    wordDoc.Close False
    Set wordDoc = Nothing
    wordApp.Quit
    Set wordApp = Nothing
End Sub
 

vc_đi chơi

Thành viên chính thức
Tham gia ngày
21 Tháng chín 2019
Bài viết
69
Được thích
8
Điểm
20
Tuổi
29
Trong Sub ChuongTrinh của bạn có gọi ImportWord và KeyDaTa. Tôi ngại đọc code của người khác nên không dò xem chúng có cần thiết hay không. Nếu chúng còn làm gì đó thì bạn tự thêm vào.

Code không kiểm tra mầu đỏ hay mầu gì. Code coi các KEY có dạng [gì đó]

Sub ChuongTrinh của tôi chỉ làm một việc là lấy các KEY từ Word vào cột B của sheet Data.

Mảng Arr tôi khai báo cho max là 10 000 key
Mã:
Sub ChuongTrinh()
Dim Arr(), count As Long, text As String, wordApp As Object, wordDoc As Object, wordSelection As Object, fso As Object
    Application.ScreenUpdating = False
    '''''Kiem tra su ton tai cua File_Mau. Neu khong thay thi Msgbox thong bao va thoat khoi chuong trinh
    With CreateObject("Scripting.FileSystemObject")
        If .FileExists(ThisWorkbook.Path & "\" & "File_Mau.doc") = False Then
            MsgBox "Khong co tap tin File_Mau.doc"
            Exit Sub
        End If
    End With
    Sheets("DaTa").Range("B3:B10000").ClearContents
    ReDim Arr(1 To 10000, 1 To 1)
    Set wordApp = CreateObject("Word.Application")
    Set wordDoc = wordApp.Documents.Open(ThisWorkbook.Path & "\File_Mau.doc")
    Set wordSelection = wordApp.Selection
    With wordSelection.Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .text = "\[*\]"
        .MatchWildcards = True
        Do While .Execute
            count = count + 1
            Arr(count, 1) = Mid(wordSelection.text, 2, Len(wordSelection.text) - 2)
        Loop
    End With
    If count Then ThisWorkbook.Worksheets("Data").Range("B3").Resize(count).Value = Arr
    wordDoc.Close False
    Set wordDoc = Nothing
    wordApp.Quit
    Set wordApp = Nothing
End Sub
Vâng, em cám ơn anh!
Anh ơi còn vấn đề này xin anh giúp em thêm chút để hoàn thiện anh ạ!
File này em cũng tham khảo trên GPE, mục đích để soạn thảo văn bản word từ excel.
Anh giúp em code trên, em có ý ghép vào code cũ để sử dụng nhưng lại bị lỗi:
Em lấy key xong rồi, và nhấn tổ hợp phím (Ctrl + shift + w) để chạy code cũ thì sẽ xuất hiện văn bản mới dạng file word có tên ứng với tên được điền vào ô B2 của sheet (Trang chu) trong file excel nhưng file word mới được soạn thảo lấy từ khóa từ excel lại báo lỗi (như hình đính kèm)
Em chưa biết về code, em nhờ anh giúp em thêm vấn đề sau (em không sử dụng code cũ nữa) để hoàn thiện chủ đề này được không ạ?
Nội dung nhờ anh giúp để hoàn thiện:

1/ Khi lấy từ khóa từ file word có tên (File_Mau) để điền vào cột B trong sheet"Data" của file excel thì những từ khóa bị trùng sẽ không điền lặp lại tính theo thứ tự từ đầu đến cuối trang word.
2/ Từ khóa được lấy anh giúp em thêm cả ký hiệu ngoặc " [......]", định dạng từ khóa ở word thế nào khi được lấy ra excel cũng tương tự vậy (cỡ chữ, kiểu chữ, fonr chữ...), ký tự từ khóa được lấy có thể lớn hơn 255 ký tự được không vậy anh?
3/
Anh cho em xin thêm code mới để sau khi lấy từ khóa sang file excel và chạy code đó sẽ xuất ra một file word mới có tên được điền theo tên ở ô B2 của sheet "Trang Chu" ( tên được chọn ở ô B2 của sheet "Trang Chu" là "Drop List" tương ứng với các tên được lấy theo tên ở các ô C2, D2, E2, F2........của sheet "Data"). Nội dung của file word mới này có nội dung tương tự file word (File_Mau) và các từ khóa trong File_Mau sẽ được thay thế bởi các từ tương ứng trong ô của các cột C, D, E, F.......thuộc sheet "Data" của file excel.
Mỗi lần điền tên khác nhau ở ô B2 của sheet "Trang Chu" và chạy code sẽ xuất ra một file word có tên là tên đã được chọn, và file word mới nằm luôn trong foder đó.

Anh giúp em mới nhé! sẽ rất cần để soạn thảo văn bản word từ excel.
Cám ơn anh nhiều!
File đính kèm bài #1
 

File đính kèm

Lần chỉnh sửa cuối:

batman1

Thành viên gắn bó
Tham gia ngày
8 Tháng chín 2014
Bài viết
2,342
Được thích
3,559
Điểm
560
1/ Khi lấy từ khóa từ file word có tên (File_Mau) để điền vào cột B trong sheet"Data" của file excel thì những từ khóa bị trùng sẽ không điền lặp lại tính theo thứ tự từ đầu đến cuối trang word.
2/ Từ khóa được lấy anh giúp em thêm cả ký hiệu ngoặc " [......]", định dạng từ khóa ở word thế nào khi được lấy ra excel cũng tương tự vậy (cỡ chữ, kiểu chữ, fonr chữ...), ký tự từ khóa được lấy có thể lớn hơn 255 ký tự được không vậy anh?
Bạn có 2 lựa chọn: hoặc nhờ tác giả code của bạn giúp hoặc nhờ tôi. Nếu nhờ tôi thì tôi đập đi xây mới. Tức bạn phải:
1. Mô tả các việc cần làm. Tôi không dò, không nghiên cứu code của người khác để đoán ý bạn.
2. Ý thức được là code của tôi có thể sẽ xung đột với code hiện có của người khác. Bạn có 2 lựa chọn: hoặc xóa hết các code cũ hoặc tự thích ứng chúng với code mới của tôi.

Trước khi làm thì vào Name Manager và xóa hết tất cả những name DMDA - hiện bạn có 2 DMDA. Một rừng name khác có lỗi nhưng tôi không quan tâm. Tự bạn phải vệ sinh gọn gàng tập tin của mình.

Các Key trong Data!B chỉ là chữ không có định dạng gì cả vì chả để làm gì. Phông chữ thì do bạn chọn thôi.

Dòng 2 trong Data phải định dạng là General.

Sub ChuongTrinh sẽ lấy các Key từ Word vào Data!B. Khi Trang Chu Activate code tạo name mới DMDA thích hợp với nội dung hiện hành tại dòng 2 trong Data. Khi chọn B2 ở Trang Chu thì code sẽ thay thế các Key ở Data!B bằng các tên ở cột tương ứng với B2 được chọn và tạo tập tin có tên là B2.

Toàn bộ code của tôi như sau:
Trong Module
Mã:
Sub ChuongTrinh()
Dim Arr(), count As Long, text As String, wordApp As Object, wordDoc As Object, wordSelection As Object, dic As Object
    Application.ScreenUpdating = False
    '''''Kiem tra su ton tai cua File_Mau. Neu khong thay thi Msgbox thong bao va thoat khoi chuong trinh
    With CreateObject("Scripting.FileSystemObject")
        If .FileExists(ThisWorkbook.Path & "\" & "File_Mau.doc") = False Then
            MsgBox "Khong co tap tin File_Mau.doc"
            Exit Sub
        End If
    End With
    Sheets("DaTa").Range("B3:B10000").ClearContents
    ReDim Arr(1 To 10000, 1 To 1)
    Set dic = CreateObject("Scripting.Dictionary")
    dic.comparemode = vbTextCompare
    Set wordApp = CreateObject("Word.Application")
    Set wordDoc = wordApp.Documents.Open(ThisWorkbook.Path & "\File_Mau.doc")
    Set wordSelection = wordApp.Selection
    With wordSelection.Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .text = "\[*\]"
        .MatchWildcards = True
        Do While .Execute
            If Not dic.exists(wordSelection.text) Then
                dic.Add wordSelection.text, ""
                count = count + 1
                Arr(count, 1) = wordSelection.text
            End If
        Loop
    End With
    If count Then ThisWorkbook.Worksheets("Data").Range("B3").Resize(count).Value = Arr
    Set dic = Nothing
    wordDoc.Close False
    Set wordDoc = Nothing
    wordApp.Quit
    Set wordApp = Nothing
End Sub

Sub createWord(ByVal filename As String, ByVal rng As Range)
Const wdFindContinue = 1
Const wdReplaceAll = 2
Dim lastCol As Long, k As Long, data(), wordApp As Object, wordDoc As Object, wordSelection As Object
    With CreateObject("Scripting.FileSystemObject")
        If Not .FileExists(ThisWorkbook.Path & "\" & "File_Mau.doc") Then
            MsgBox "Khong co tap tin File_Mau.doc"
            Exit Sub
        End If
    End With
    data = rng.Value
    lastCol = UBound(data, 2)
    Set wordApp = CreateObject("Word.Application")
    Set wordDoc = wordApp.Documents.Open(ThisWorkbook.Path & "\File_Mau.doc")
    Set wordSelection = wordApp.Selection
    With wordSelection.Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .Forward = True
        .Wrap = wdFindContinue
    End With
    For k = 1 To UBound(data)
        With wordSelection.Find
            .text = data(k, 1)
            .Replacement.text = data(k, lastCol)
            .Execute Replace:=wdReplaceAll
        End With
    Next k
   
    wordDoc.SaveAs ThisWorkbook.Path & "\" & filename & ".doc"
    wordDoc.Close
    Set wordDoc = Nothing
    wordApp.Quit
    Set wordApp = Nothing
   
    MsgBox "Da tao tap tin " & filename & ".doc"
End Sub
Trong sheet Trang Chu
Mã:
Private Sub Worksheet_Activate()
Dim lastCol As Long
    With ThisWorkbook.Worksheets("Data")
        lastCol = .Cells(2, Columns.count).End(xlToLeft).Column
        If lastCol >= 3 Then
            On Error Resume Next
            ActiveWorkbook.Names("DMDA").Delete
            ActiveWorkbook.Names.Add "DMDA", "=Data!" & .Range("C2").Resize(1, lastCol - 2).Address
            With Me.Range("B2").Validation
                .Delete
                .Add Type:=xlValidateList, Formula1:="=DMDA"
                .InCellDropdown = True
            End With
            On Error GoTo 0
        End If
    End With
End Sub

Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
    If Not Intersect(Target, [b2]) Is Nothing Then
        Cancel = True
    End If
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
Dim lastRow As Long, rng As Range, sh As Worksheet, cell_ As Range
    If Target.Address <> "$B$2" Then Exit Sub
    Set sh = ThisWorkbook.Worksheets("Data")
    lastRow = sh.Cells(Rows.count, "B").End(xlUp).Row
    If lastRow < 3 Then Exit Sub
    Set rng = sh.Range("DMDA").Find(Me.Range("B2").Value, , xlValues, xlWhole)
    If rng Is Nothing Then Exit Sub
    With sh
        createWord Me.Range("B2").Value, .Range(.Range("B3"), .Cells(lastRow, rng.Column))
    End With
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If Target.Address = "$B$2" Then
        Application.SendKeys "%{Down}"
    End If
End Sub
 
Lần chỉnh sửa cuối:

vc_đi chơi

Thành viên chính thức
Tham gia ngày
21 Tháng chín 2019
Bài viết
69
Được thích
8
Điểm
20
Tuổi
29
Bạn có 2 lựa chọn: hoặc nhờ tác giả code của bạn giúp hoặc nhờ tôi. Nếu nhờ tôi thì tôi đập đi xây mới. Tức bạn phải:
1. Mô tả các việc cần làm. Tôi không dò, không nghiên cứu code của người khác để đoán ý bạn.
2. Ý thức được là code của tôi có thể sẽ xung đột với code hiện có của người khác. Bạn có 2 lựa chọn: hoặc xóa hết các code cũ hoặc tự thích ứng chúng với code mới của tôi.

Trước khi làm thì vào Name Manager và xóa hết tất cả những name DMDA - hiện bạn có 2 DMDA. Một rừng name khác có lỗi nhưng tôi không quan tâm. Tự bạn phải vệ sinh gọn gàng tập tin của mình.

Các Key trong Data!B chỉ là chữ không có định dạng gì cả vì chả để làm gì. Phông chữ thì do bạn chọn thôi.

Dòng 2 trong Data phải định dạng là General.

Sub ChuongTrinh sẽ lấy các Key từ Word vào Data!B. Khi Trang Chu Activate code tạo name mới DMDA thích hợp với nội dung hiện hành tại dòng 2 trong Data. Khi chọn B2 ở Trang Chu thì code sẽ thay thế các Key ở Data!B bằng các tên ở cột tương ứng với B2 được chọn và tạo tập tin có tên là B2.

Toàn bộ code của tôi như sau:
Trong Module
Mã:
Sub ChuongTrinh()
Dim Arr(), count As Long, text As String, wordApp As Object, wordDoc As Object, wordSelection As Object, dic As Object
    Application.ScreenUpdating = False
    '''''Kiem tra su ton tai cua File_Mau. Neu khong thay thi Msgbox thong bao va thoat khoi chuong trinh
    With CreateObject("Scripting.FileSystemObject")
        If .FileExists(ThisWorkbook.Path & "\" & "File_Mau.doc") = False Then
            MsgBox "Khong co tap tin File_Mau.doc"
            Exit Sub
        End If
    End With
    Sheets("DaTa").Range("B3:B10000").ClearContents
    ReDim Arr(1 To 10000, 1 To 1)
    Set dic = CreateObject("Scripting.Dictionary")
    dic.comparemode = vbTextCompare
    Set wordApp = CreateObject("Word.Application")
    Set wordDoc = wordApp.Documents.Open(ThisWorkbook.Path & "\File_Mau.doc")
    Set wordSelection = wordApp.Selection
    With wordSelection.Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .text = "\[*\]"
        .MatchWildcards = True
        Do While .Execute
            If Not dic.exists(wordSelection.text) Then
                dic.Add wordSelection.text, ""
                count = count + 1
                Arr(count, 1) = wordSelection.text
            End If
        Loop
    End With
    If count Then ThisWorkbook.Worksheets("Data").Range("B3").Resize(count).Value = Arr
    Set dic = Nothing
    wordDoc.Close False
    Set wordDoc = Nothing
    wordApp.Quit
    Set wordApp = Nothing
End Sub

Sub createWord(ByVal filename As String, ByVal rng As Range)
Const wdFindContinue = 1
Const wdReplaceAll = 2
Dim lastCol As Long, k As Long, data(), wordApp As Object, wordDoc As Object, wordSelection As Object
    With CreateObject("Scripting.FileSystemObject")
        If Not .FileExists(ThisWorkbook.Path & "\" & "File_Mau.doc") Then
            MsgBox "Khong co tap tin File_Mau.doc"
            Exit Sub
        End If
    End With
    data = rng.Value
    lastCol = UBound(data, 2)
    Set wordApp = CreateObject("Word.Application")
    Set wordDoc = wordApp.Documents.Open(ThisWorkbook.Path & "\File_Mau.doc")
    Set wordSelection = wordApp.Selection
    With wordSelection.Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .Forward = True
        .Wrap = wdFindContinue
    End With
    For k = 1 To UBound(data)
        With wordSelection.Find
            .text = data(k, 1)
            .Replacement.text = data(k, lastCol)
            .Execute Replace:=wdReplaceAll
        End With
    Next k
 
    wordDoc.SaveAs ThisWorkbook.Path & "\" & filename & ".doc"
    wordDoc.Close
    Set wordDoc = Nothing
    wordApp.Quit
    Set wordApp = Nothing
 
    MsgBox "Da tao tap tin " & filename & ".doc"
End Sub
Trong sheet Trang Chu
Mã:
Private Sub Worksheet_Activate()
Dim lastCol As Long
    With ThisWorkbook.Worksheets("Data")
        lastCol = .Cells(2, Columns.count).End(xlToLeft).Column
        If lastCol >= 3 Then
            On Error Resume Next
            ActiveWorkbook.Names("DMDA").Delete
            ActiveWorkbook.Names.Add "DMDA", "=Data!" & .Range("C2").Resize(1, lastCol - 2).Address
            With Me.Range("B2").Validation
                .Delete
                .Add Type:=xlValidateList, Formula1:="=DMDA"
                .InCellDropdown = True
            End With
            On Error GoTo 0
        End If
    End With
End Sub

Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
    If Not Intersect(Target, [b2]) Is Nothing Then
        Cancel = True
    End If
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
Dim lastRow As Long, rng As Range, sh As Worksheet, cell_ As Range
    If Target.Address <> "$B$2" Then Exit Sub
    Set sh = ThisWorkbook.Worksheets("Data")
    lastRow = sh.Cells(Rows.count, "B").End(xlUp).Row
    If lastRow < 3 Then Exit Sub
    Set rng = sh.Range("DMDA").Find(Me.Range("B2").Value, , xlValues, xlWhole)
    If rng Is Nothing Then Exit Sub
    With sh
        createWord Me.Range("B2").Value, .Range(.Range("B3"), .Cells(lastRow, rng.Column))
    End With
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If Target.Address = "$B$2" Then
        Application.SendKeys "%{Down}"
    End If
End Sub
Dạ! em cám ơn anh rất rất nhiều.
Để em chạy thử, chúc anh nhiều sức khỏe và niềm vui.
 

vc_đi chơi

Thành viên chính thức
Tham gia ngày
21 Tháng chín 2019
Bài viết
69
Được thích
8
Điểm
20
Tuổi
29
Bạn có 2 lựa chọn: hoặc nhờ tác giả code của bạn giúp hoặc nhờ tôi. Nếu nhờ tôi thì tôi đập đi xây mới. Tức bạn phải:
1. Mô tả các việc cần làm. Tôi không dò, không nghiên cứu code của người khác để đoán ý bạn.
2. Ý thức được là code của tôi có thể sẽ xung đột với code hiện có của người khác. Bạn có 2 lựa chọn: hoặc xóa hết các code cũ hoặc tự thích ứng chúng với code mới của tôi.

Trước khi làm thì vào Name Manager và xóa hết tất cả những name DMDA - hiện bạn có 2 DMDA. Một rừng name khác có lỗi nhưng tôi không quan tâm. Tự bạn phải vệ sinh gọn gàng tập tin của mình.

Các Key trong Data!B chỉ là chữ không có định dạng gì cả vì chả để làm gì. Phông chữ thì do bạn chọn thôi.

Dòng 2 trong Data phải định dạng là General.

Sub ChuongTrinh sẽ lấy các Key từ Word vào Data!B. Khi Trang Chu Activate code tạo name mới DMDA thích hợp với nội dung hiện hành tại dòng 2 trong Data. Khi chọn B2 ở Trang Chu thì code sẽ thay thế các Key ở Data!B bằng các tên ở cột tương ứng với B2 được chọn và tạo tập tin có tên là B2.

Toàn bộ code của tôi như sau:
Trong Module
Mã:
Sub ChuongTrinh()
Dim Arr(), count As Long, text As String, wordApp As Object, wordDoc As Object, wordSelection As Object, dic As Object
    Application.ScreenUpdating = False
    '''''Kiem tra su ton tai cua File_Mau. Neu khong thay thi Msgbox thong bao va thoat khoi chuong trinh
    With CreateObject("Scripting.FileSystemObject")
        If .FileExists(ThisWorkbook.Path & "\" & "File_Mau.doc") = False Then
            MsgBox "Khong co tap tin File_Mau.doc"
            Exit Sub
        End If
    End With
    Sheets("DaTa").Range("B3:B10000").ClearContents
    ReDim Arr(1 To 10000, 1 To 1)
    Set dic = CreateObject("Scripting.Dictionary")
    dic.comparemode = vbTextCompare
    Set wordApp = CreateObject("Word.Application")
    Set wordDoc = wordApp.Documents.Open(ThisWorkbook.Path & "\File_Mau.doc")
    Set wordSelection = wordApp.Selection
    With wordSelection.Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .text = "\[*\]"
        .MatchWildcards = True
        Do While .Execute
            If Not dic.exists(wordSelection.text) Then
                dic.Add wordSelection.text, ""
                count = count + 1
                Arr(count, 1) = wordSelection.text
            End If
        Loop
    End With
    If count Then ThisWorkbook.Worksheets("Data").Range("B3").Resize(count).Value = Arr
    Set dic = Nothing
    wordDoc.Close False
    Set wordDoc = Nothing
    wordApp.Quit
    Set wordApp = Nothing
End Sub

Sub createWord(ByVal filename As String, ByVal rng As Range)
Const wdFindContinue = 1
Const wdReplaceAll = 2
Dim lastCol As Long, k As Long, data(), wordApp As Object, wordDoc As Object, wordSelection As Object
    With CreateObject("Scripting.FileSystemObject")
        If Not .FileExists(ThisWorkbook.Path & "\" & "File_Mau.doc") Then
            MsgBox "Khong co tap tin File_Mau.doc"
            Exit Sub
        End If
    End With
    data = rng.Value
    lastCol = UBound(data, 2)
    Set wordApp = CreateObject("Word.Application")
    Set wordDoc = wordApp.Documents.Open(ThisWorkbook.Path & "\File_Mau.doc")
    Set wordSelection = wordApp.Selection
    With wordSelection.Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .Forward = True
        .Wrap = wdFindContinue
    End With
    For k = 1 To UBound(data)
        With wordSelection.Find
            .text = data(k, 1)
            .Replacement.text = data(k, lastCol)
            .Execute Replace:=wdReplaceAll
        End With
    Next k

    wordDoc.SaveAs ThisWorkbook.Path & "\" & filename & ".doc"
    wordDoc.Close
    Set wordDoc = Nothing
    wordApp.Quit
    Set wordApp = Nothing

    MsgBox "Da tao tap tin " & filename & ".doc"
End Sub
Trong sheet Trang Chu
Mã:
Private Sub Worksheet_Activate()
Dim lastCol As Long
    With ThisWorkbook.Worksheets("Data")
        lastCol = .Cells(2, Columns.count).End(xlToLeft).Column
        If lastCol >= 3 Then
            On Error Resume Next
            ActiveWorkbook.Names("DMDA").Delete
            ActiveWorkbook.Names.Add "DMDA", "=Data!" & .Range("C2").Resize(1, lastCol - 2).Address
            With Me.Range("B2").Validation
                .Delete
                .Add Type:=xlValidateList, Formula1:="=DMDA"
                .InCellDropdown = True
            End With
            On Error GoTo 0
        End If
    End With
End Sub

Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
    If Not Intersect(Target, [b2]) Is Nothing Then
        Cancel = True
    End If
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
Dim lastRow As Long, rng As Range, sh As Worksheet, cell_ As Range
    If Target.Address <> "$B$2" Then Exit Sub
    Set sh = ThisWorkbook.Worksheets("Data")
    lastRow = sh.Cells(Rows.count, "B").End(xlUp).Row
    If lastRow < 3 Then Exit Sub
    Set rng = sh.Range("DMDA").Find(Me.Range("B2").Value, , xlValues, xlWhole)
    If rng Is Nothing Then Exit Sub
    With sh
        createWord Me.Range("B2").Value, .Range(.Range("B3"), .Cells(lastRow, rng.Column))
    End With
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If Target.Address = "$B$2" Then
        Application.SendKeys "%{Down}"
    End If
End Sub
Em vừa chạy code anh viết giúp, em làm phiền anh chút xíu ạ:
1/ Nếu file Word có tên ''File_Mau" mà mở lên cùng với file excel đó thì khi chạy code để lấy key thì bị báo lỗi (như hình đính kèm)
Chỉ khi tắt file Word đó đi và chạy code trong file excel thì mới được ạ? (tức là file Word (File_Mau) và file excel không được mở lên đồng thời, phải tắt file Word đi thì mới chạy được code)
2/ Có thể tự động mở file word mới vừa tạo được không vậy anh? (ngay sau khi điền tên Key vào ô B2 của sheet "Trang Chu" và đã tạo ra file word mới thì ngay sau đó xuất hiện giao diện hỏi "có muốn mở file word vừa được tạo hay không chả hạn" nếu nhấn có sẽ mở file word mới, nhấn không sẽ không mở)
Anh cho em ký kiến về 2 vấn đề em nêu trên ạ! có thể mở đồng thời được file_Mau và file Excel mà chạy code không báo lỗi không ạ? và tối đa tạo được bao nhiêu file word mới tương ứng với cột trong sheet "Data" vậy anh?
 
Lần chỉnh sửa cuối:

batman1

Thành viên gắn bó
Tham gia ngày
8 Tháng chín 2014
Bài viết
2,342
Được thích
3,559
Điểm
560
Em vừa chạy code anh viết giúp, em làm phiền anh chút xíu ạ:
1/ Nếu file Word có tên ''File_Mau" mà mở lên cùng với file excel đó thì khi chạy code để lấy key thì bị báo lỗi (như hình đính kèm)
Chỉ khi tắt file Word đó đi và chạy code trong file excel thì mới được ạ? (tức là file Word (File_Mau) và file excel không được mở lên đồng thời, phải tắt file Word đi thì mới chạy được code)
Thôi tôi không sửa nữa đâu. Một lúc bạn chỉ làm được 1 việc. Vậy thì nếu muốn làm việc với Word thì chạy Excel làm gì? Còn nếu muốn làm việc với Excel thì đừng mở Word hoặc đang mở thì đóng. Thế thôi. Cái gì cũng code?
2/ Có thể tự động mở file word mới vừa tạo được không vậy anh? (ngay sau khi điền tên Key vào ô B2 của sheet "Trang Chu" và đã tạo ra file word mới thì ngay sau đó xuất hiện giao diện hỏi "có muốn mở file word vừa được tạo hay không chả hạn" nếu nhấn có sẽ mở file word mới, nhấn không sẽ không mở)
Thay
Mã:
wordDoc.Close
    Set wordDoc = Nothing
    wordApp.Quit
    Set wordApp = Nothing
   
    MsgBox "Da tao tap tin " & filename & ".doc"
bằng
Mã:
If MsgBox("Co mo tap tin " & filename & ".doc khong?", vbYesNo) = vbYes Then
    wordApp.Visible = True
Else
    wordDoc.Close
    wordApp.Quit
End If
 

vc_đi chơi

Thành viên chính thức
Tham gia ngày
21 Tháng chín 2019
Bài viết
69
Được thích
8
Điểm
20
Tuổi
29
Thôi tôi không sửa nữa đâu. Một lúc bạn chỉ làm được 1 việc. Vậy thì nếu muốn làm việc với Word thì chạy Excel làm gì? Còn nếu muốn làm việc với Excel thì đừng mở Word hoặc đang mở thì đóng. Thế thôi. Cái gì cũng code?

Thay
Mã:
wordDoc.Close
    Set wordDoc = Nothing
    wordApp.Quit
    Set wordApp = Nothing
  
    MsgBox "Da tao tap tin " & filename & ".doc"
bằng
Mã:
If MsgBox("Co mo tap tin " & filename & ".doc khong?", vbYesNo) = vbYes Then
    wordApp.Visible = True
Else
    wordDoc.Close
    wordApp.Quit
End If
Dạ! Em cám anh, chúc anh buổi tối vui vẻ.
 

Cát Lượng

Thành viên thường trực
Tham gia ngày
14 Tháng mười một 2018
Bài viết
319
Được thích
36
Điểm
185
Tuổi
32
Bạn có 2 lựa chọn: hoặc nhờ tác giả code của bạn giúp hoặc nhờ tôi. Nếu nhờ tôi thì tôi đập đi xây mới. Tức bạn phải:
1. Mô tả các việc cần làm. Tôi không dò, không nghiên cứu code của người khác để đoán ý bạn.
2. Ý thức được là code của tôi có thể sẽ xung đột với code hiện có của người khác. Bạn có 2 lựa chọn: hoặc xóa hết các code cũ hoặc tự thích ứng chúng với code mới của tôi.

Trước khi làm thì vào Name Manager và xóa hết tất cả những name DMDA - hiện bạn có 2 DMDA. Một rừng name khác có lỗi nhưng tôi không quan tâm. Tự bạn phải vệ sinh gọn gàng tập tin của mình.

Các Key trong Data!B chỉ là chữ không có định dạng gì cả vì chả để làm gì. Phông chữ thì do bạn chọn thôi.

Dòng 2 trong Data phải định dạng là General.

Sub ChuongTrinh sẽ lấy các Key từ Word vào Data!B. Khi Trang Chu Activate code tạo name mới DMDA thích hợp với nội dung hiện hành tại dòng 2 trong Data. Khi chọn B2 ở Trang Chu thì code sẽ thay thế các Key ở Data!B bằng các tên ở cột tương ứng với B2 được chọn và tạo tập tin có tên là B2.

Toàn bộ code của tôi như sau:
Trong Module
Mã:
Sub ChuongTrinh()
Dim Arr(), count As Long, text As String, wordApp As Object, wordDoc As Object, wordSelection As Object, dic As Object
    Application.ScreenUpdating = False
    '''''Kiem tra su ton tai cua File_Mau. Neu khong thay thi Msgbox thong bao va thoat khoi chuong trinh
    With CreateObject("Scripting.FileSystemObject")
        If .FileExists(ThisWorkbook.Path & "\" & "File_Mau.doc") = False Then
            MsgBox "Khong co tap tin File_Mau.doc"
            Exit Sub
        End If
    End With
    Sheets("DaTa").Range("B3:B10000").ClearContents
    ReDim Arr(1 To 10000, 1 To 1)
    Set dic = CreateObject("Scripting.Dictionary")
    dic.comparemode = vbTextCompare
    Set wordApp = CreateObject("Word.Application")
    Set wordDoc = wordApp.Documents.Open(ThisWorkbook.Path & "\File_Mau.doc")
    Set wordSelection = wordApp.Selection
    With wordSelection.Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .text = "\[*\]"
        .MatchWildcards = True
        Do While .Execute
            If Not dic.exists(wordSelection.text) Then
                dic.Add wordSelection.text, ""
                count = count + 1
                Arr(count, 1) = wordSelection.text
            End If
        Loop
    End With
    If count Then ThisWorkbook.Worksheets("Data").Range("B3").Resize(count).Value = Arr
    Set dic = Nothing
    wordDoc.Close False
    Set wordDoc = Nothing
    wordApp.Quit
    Set wordApp = Nothing
End Sub

Sub createWord(ByVal filename As String, ByVal rng As Range)
Const wdFindContinue = 1
Const wdReplaceAll = 2
Dim lastCol As Long, k As Long, data(), wordApp As Object, wordDoc As Object, wordSelection As Object
    With CreateObject("Scripting.FileSystemObject")
        If Not .FileExists(ThisWorkbook.Path & "\" & "File_Mau.doc") Then
            MsgBox "Khong co tap tin File_Mau.doc"
            Exit Sub
        End If
    End With
    data = rng.Value
    lastCol = UBound(data, 2)
    Set wordApp = CreateObject("Word.Application")
    Set wordDoc = wordApp.Documents.Open(ThisWorkbook.Path & "\File_Mau.doc")
    Set wordSelection = wordApp.Selection
    With wordSelection.Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .Forward = True
        .Wrap = wdFindContinue
    End With
    For k = 1 To UBound(data)
        With wordSelection.Find
            .text = data(k, 1)
            .Replacement.text = data(k, lastCol)
            .Execute Replace:=wdReplaceAll
        End With
    Next k

    wordDoc.SaveAs ThisWorkbook.Path & "\" & filename & ".doc"
    wordDoc.Close
    Set wordDoc = Nothing
    wordApp.Quit
    Set wordApp = Nothing

    MsgBox "Da tao tap tin " & filename & ".doc"
End Sub
Trong sheet Trang Chu
Mã:
Private Sub Worksheet_Activate()
Dim lastCol As Long
    With ThisWorkbook.Worksheets("Data")
        lastCol = .Cells(2, Columns.count).End(xlToLeft).Column
        If lastCol >= 3 Then
            On Error Resume Next
            ActiveWorkbook.Names("DMDA").Delete
            ActiveWorkbook.Names.Add "DMDA", "=Data!" & .Range("C2").Resize(1, lastCol - 2).Address
            With Me.Range("B2").Validation
                .Delete
                .Add Type:=xlValidateList, Formula1:="=DMDA"
                .InCellDropdown = True
            End With
            On Error GoTo 0
        End If
    End With
End Sub

Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
    If Not Intersect(Target, [b2]) Is Nothing Then
        Cancel = True
    End If
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
Dim lastRow As Long, rng As Range, sh As Worksheet, cell_ As Range
    If Target.Address <> "$B$2" Then Exit Sub
    Set sh = ThisWorkbook.Worksheets("Data")
    lastRow = sh.Cells(Rows.count, "B").End(xlUp).Row
    If lastRow < 3 Then Exit Sub
    Set rng = sh.Range("DMDA").Find(Me.Range("B2").Value, , xlValues, xlWhole)
    If rng Is Nothing Then Exit Sub
    With sh
        createWord Me.Range("B2").Value, .Range(.Range("B3"), .Cells(lastRow, rng.Column))
    End With
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If Target.Address = "$B$2" Then
        Application.SendKeys "%{Down}"
    End If
End Sub
ChàoThầy! em thấy chủ đề này rất thiết thực.

Có vấn đề sau em xin được Thầy giúp : khi lấy được từ khóa [Key] từ word để sang excel rồi và sau đó điền nội dung vào các cột C, cột D, cột E, cột F...vv....và chọn tên trong ô B2 của sheet_Trang Chu thì biên bản mới được xuất ra.
Nhưng nếu chèn thêm từ khóa vào file word có tên File_Mau vào vị trí bất kỳ trong file đó và lấy lại [key] sang file exel
Thì những nội dung đã được điền ở cột C, cột D, cột E, cột F...vv.... sẽ bị thay đổi, bị nhẩy (tức là các từ khóa cũ trong word và key được lấy sang exel sẽ không còn tương ứng với [key] ban đầu lúc chưa chèn thêm ký tự.

Từ khóa được lấy thêm vào do đó vị trí dòng của [Key] sẽ thay đổi trong khi đó nội dung đã điền trong các cột cột C, cột D, cột E, cột F...vv....lại không thay đổi so với lúc chưa lấy [key] mới, như vậy mỗi lần chèn thêm từ khóa vào File_Mau và lấy [key] sang file excel sẽ phải điền lại tất cả nội dung tương ứng trong các cột C, cột D, cột E, cột F...vv....ở sheet_Data.

Thầy giúp em để mỗi lần chèn từ khóa vào File_Mau mà [key] ở cột B trong sheet_Data tương ứng với nội dung điền trong cột C, cột D, ...vv... không bị thay đổi ( [key] thay đổi vị trí nhưng các nội dung đã điền ở cột C, cột D...vv....luôn gắn liền với [key] đó như lúc chưa chèn thêm từ khóa vào File_Mau).

Em cám ơn Thầy!
 
Lần chỉnh sửa cuối:

chothadiem

Thành viên hoạt động
Tham gia ngày
29 Tháng mười 2018
Bài viết
107
Được thích
23
Điểm
170
Tuổi
32
Bạn có 2 lựa chọn: hoặc nhờ tác giả code của bạn giúp hoặc nhờ tôi. Nếu nhờ tôi thì tôi đập đi xây mới. Tức bạn phải:
1. Mô tả các việc cần làm. Tôi không dò, không nghiên cứu code của người khác để đoán ý bạn.
2. Ý thức được là code của tôi có thể sẽ xung đột với code hiện có của người khác. Bạn có 2 lựa chọn: hoặc xóa hết các code cũ hoặc tự thích ứng chúng với code mới của tôi.

Trước khi làm thì vào Name Manager và xóa hết tất cả những name DMDA - hiện bạn có 2 DMDA. Một rừng name khác có lỗi nhưng tôi không quan tâm. Tự bạn phải vệ sinh gọn gàng tập tin của mình.

Các Key trong Data!B chỉ là chữ không có định dạng gì cả vì chả để làm gì. Phông chữ thì do bạn chọn thôi.

Dòng 2 trong Data phải định dạng là General.

Sub ChuongTrinh sẽ lấy các Key từ Word vào Data!B. Khi Trang Chu Activate code tạo name mới DMDA thích hợp với nội dung hiện hành tại dòng 2 trong Data. Khi chọn B2 ở Trang Chu thì code sẽ thay thế các Key ở Data!B bằng các tên ở cột tương ứng với B2 được chọn và tạo tập tin có tên là B2.

Toàn bộ code của tôi như sau:
Trong Module
Mã:
Sub ChuongTrinh()
Dim Arr(), count As Long, text As String, wordApp As Object, wordDoc As Object, wordSelection As Object, dic As Object
    Application.ScreenUpdating = False
    '''''Kiem tra su ton tai cua File_Mau. Neu khong thay thi Msgbox thong bao va thoat khoi chuong trinh
    With CreateObject("Scripting.FileSystemObject")
        If .FileExists(ThisWorkbook.Path & "\" & "File_Mau.doc") = False Then
            MsgBox "Khong co tap tin File_Mau.doc"
            Exit Sub
        End If
    End With
    Sheets("DaTa").Range("B3:B10000").ClearContents
    ReDim Arr(1 To 10000, 1 To 1)
    Set dic = CreateObject("Scripting.Dictionary")
    dic.comparemode = vbTextCompare
    Set wordApp = CreateObject("Word.Application")
    Set wordDoc = wordApp.Documents.Open(ThisWorkbook.Path & "\File_Mau.doc")
    Set wordSelection = wordApp.Selection
    With wordSelection.Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .text = "\[*\]"
        .MatchWildcards = True
        Do While .Execute
            If Not dic.exists(wordSelection.text) Then
                dic.Add wordSelection.text, ""
                count = count + 1
                Arr(count, 1) = wordSelection.text
            End If
        Loop
    End With
    If count Then ThisWorkbook.Worksheets("Data").Range("B3").Resize(count).Value = Arr
    Set dic = Nothing
    wordDoc.Close False
    Set wordDoc = Nothing
    wordApp.Quit
    Set wordApp = Nothing
End Sub

Sub createWord(ByVal filename As String, ByVal rng As Range)
Const wdFindContinue = 1
Const wdReplaceAll = 2
Dim lastCol As Long, k As Long, data(), wordApp As Object, wordDoc As Object, wordSelection As Object
    With CreateObject("Scripting.FileSystemObject")
        If Not .FileExists(ThisWorkbook.Path & "\" & "File_Mau.doc") Then
            MsgBox "Khong co tap tin File_Mau.doc"
            Exit Sub
        End If
    End With
    data = rng.Value
    lastCol = UBound(data, 2)
    Set wordApp = CreateObject("Word.Application")
    Set wordDoc = wordApp.Documents.Open(ThisWorkbook.Path & "\File_Mau.doc")
    Set wordSelection = wordApp.Selection
    With wordSelection.Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .Forward = True
        .Wrap = wdFindContinue
    End With
    For k = 1 To UBound(data)
        With wordSelection.Find
            .text = data(k, 1)
            .Replacement.text = data(k, lastCol)
            .Execute Replace:=wdReplaceAll
        End With
    Next k
  
    wordDoc.SaveAs ThisWorkbook.Path & "\" & filename & ".doc"
    wordDoc.Close
    Set wordDoc = Nothing
    wordApp.Quit
    Set wordApp = Nothing
  
    MsgBox "Da tao tap tin " & filename & ".doc"
End Sub
Trong sheet Trang Chu
Mã:
Private Sub Worksheet_Activate()
Dim lastCol As Long
    With ThisWorkbook.Worksheets("Data")
        lastCol = .Cells(2, Columns.count).End(xlToLeft).Column
        If lastCol >= 3 Then
            On Error Resume Next
            ActiveWorkbook.Names("DMDA").Delete
            ActiveWorkbook.Names.Add "DMDA", "=Data!" & .Range("C2").Resize(1, lastCol - 2).Address
            With Me.Range("B2").Validation
                .Delete
                .Add Type:=xlValidateList, Formula1:="=DMDA"
                .InCellDropdown = True
            End With
            On Error GoTo 0
        End If
    End With
End Sub

Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
    If Not Intersect(Target, [b2]) Is Nothing Then
        Cancel = True
    End If
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
Dim lastRow As Long, rng As Range, sh As Worksheet, cell_ As Range
    If Target.Address <> "$B$2" Then Exit Sub
    Set sh = ThisWorkbook.Worksheets("Data")
    lastRow = sh.Cells(Rows.count, "B").End(xlUp).Row
    If lastRow < 3 Then Exit Sub
    Set rng = sh.Range("DMDA").Find(Me.Range("B2").Value, , xlValues, xlWhole)
    If rng Is Nothing Then Exit Sub
    With sh
        createWord Me.Range("B2").Value, .Range(.Range("B3"), .Cells(lastRow, rng.Column))
    End With
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If Target.Address = "$B$2" Then
        Application.SendKeys "%{Down}"
    End If
End Sub
[Key] và nội dung được điền ở các cột của sheet Data sẽ bị đảo vị trí tương ứng khi [key] mới được tạo
Anh batman1 giúp em khắc phục mới
Bài đã được tự động gộp:

ChàoThầy! em thấy chủ đề này rất thiết thực.

Có vấn đề sau em xin được Thầy giúp : khi lấy được từ khóa [Key] từ word để sang excel rồi và sau đó điền nội dung vào các cột C, cột D, cột E, cột F...vv....và chọn tên trong ô B2 của sheet_Trang Chu thì biên bản mới được xuất ra.
Nhưng nếu chèn thêm từ khóa vào file word có tên File_Mau vào vị trí bất kỳ trong file đó và lấy lại [key] sang file exel
Thì những nội dung đã được điền ở cột C, cột D, cột E, cột F...vv.... sẽ bị thay đổi, bị nhẩy (tức là các từ khóa cũ trong word và key được lấy sang exel sẽ không còn tương ứng với [key] ban đầu lúc chưa chèn thêm ký tự.

Từ khóa được lấy thêm vào do đó vị trí dòng của [Key] sẽ thay đổi trong khi đó nội dung đã điền trong các cột cột C, cột D, cột E, cột F...vv....lại không thay đổi so với lúc chưa lấy [key] mới, như vậy mỗi lần chèn thêm từ khóa vào File_Mau và lấy [key] sang file excel sẽ phải điền lại tất cả nội dung tương ứng trong các cột C, cột D, cột E, cột F...vv....ở sheet_Data.

Thầy giúp em để mỗi lần chèn từ khóa vào File_Mau mà [key] ở cột B trong sheet_Data tương ứng với nội dung điền trong cột C, cột D, ...vv... không bị thay đổi ( [key] thay đổi vị trí nhưng các nội dung đã điền ở cột C, cột D...vv....luôn gắn liền với [key] đó như lúc chưa chèn thêm từ khóa vào File_Mau).

Em cám ơn Thầy!
Gần đúng ý mình
 

dangky47h

Thành viên thường trực
Tham gia ngày
4 Tháng chín 2017
Bài viết
309
Được thích
33
Điểm
185
Tuổi
32
ChàoThầy! em thấy chủ đề này rất thiết thực.

Có vấn đề sau em xin được Thầy giúp : khi lấy được từ khóa [Key] từ word để sang excel rồi và sau đó điền nội dung vào các cột C, cột D, cột E, cột F...vv....và chọn tên trong ô B2 của sheet_Trang Chu thì biên bản mới được xuất ra.
Nhưng nếu chèn thêm từ khóa vào file word có tên File_Mau vào vị trí bất kỳ trong file đó và lấy lại [key] sang file exel
Thì những nội dung đã được điền ở cột C, cột D, cột E, cột F...vv.... sẽ bị thay đổi, bị nhẩy (tức là các từ khóa cũ trong word và key được lấy sang exel sẽ không còn tương ứng với [key] ban đầu lúc chưa chèn thêm ký tự.

Từ khóa được lấy thêm vào do đó vị trí dòng của [Key] sẽ thay đổi trong khi đó nội dung đã điền trong các cột cột C, cột D, cột E, cột F...vv....lại không thay đổi so với lúc chưa lấy [key] mới, như vậy mỗi lần chèn thêm từ khóa vào File_Mau và lấy [key] sang file excel sẽ phải điền lại tất cả nội dung tương ứng trong các cột C, cột D, cột E, cột F...vv....ở sheet_Data.

Thầy giúp em để mỗi lần chèn từ khóa vào File_Mau mà [key] ở cột B trong sheet_Data tương ứng với nội dung điền trong cột C, cột D, ...vv... không bị thay đổi ( [key] thay đổi vị trí nhưng các nội dung đã điền ở cột C, cột D...vv....luôn gắn liền với [key] đó như lúc chưa chèn thêm từ khóa vào File_Mau).

Em cám ơn Thầy!
Chị đặt tên và cố định lại xem
 

batman1

Thành viên gắn bó
Tham gia ngày
8 Tháng chín 2014
Bài viết
2,342
Được thích
3,559
Điểm
560
Thầy giúp em để mỗi lần chèn từ khóa vào File_Mau mà [key] ở cột B trong sheet_Data tương ứng với nội dung điền trong cột C, cột D, ...vv... không bị thay đổi ( [key] thay đổi vị trí nhưng các nội dung đã điền ở cột C, cột D...vv....luôn gắn liền với [key] đó như lúc chưa chèn thêm từ khóa vào File_Mau).
Lần sau thì nên làm như chủ chủ đề. Tức đính kèm tập tin và mô tả kỹ yêu cầu. Bắt người khác đọc 100 bài trong chủ đề nào đó và tải hàng loạt tập tin đính kèm để đoán ý tác giả định nói tới bài nào, tập tin nào thì ít ai bỏ công ra giúp. Nhớ nhắc cả bạn Bùi Thúy Thúy ngồi cùng bàn nhé.

Nhìn qua thì như sau, bạn hãy kiểm tra kỹ, bởi tôi không kiểm tra phần thêm KEY này.

Tôi giả thiết là yêu cầu của bạn y như yêu cầu của chủ chủ đề, nhưng thêm phần thêm KEY trong File_Mau.

Code vẫn chỉ có những SUB như bài #6 nhưng thay Sub ChuongTrinh bằng
Mã:
Sub ChuongTrinh()
Dim Arr(), lastRow As Long, k As Long, count As Long, text As String, wordApp As Object, wordDoc As Object, wordSelection As Object, dic As Object
    Application.ScreenUpdating = False
    '''''Kiem tra su ton tai cua File_Mau. Neu khong thay thi Msgbox thong bao va thoat khoi chuong trinh
    With CreateObject("Scripting.FileSystemObject")
        If .FileExists(ThisWorkbook.Path & "\" & "File_Mau.doc") = False Then
            MsgBox "Khong co tap tin File_Mau.doc"
            Exit Sub
        End If
    End With
    Set dic = CreateObject("Scripting.Dictionary")
    dic.comparemode = vbTextCompare
'    ---------- ghi KEY da co vao dic - bat dau ------------
    With ThisWorkbook.Worksheets("Data")
        lastRow = .Cells(Rows.count, "B").End(xlUp).Row
        Arr = .Range("B3:B" & lastRow + 2).Value
    End With
    For k = 1 To UBound(Arr) - 2
        If Arr(k, 1) <> "" Then dic.Add Arr(k, 1), ""
    Next k
'    ---------- ghi KEY da co vao dic - ket thuc ------------
    ReDim Arr(1 To 10000, 1 To 1)
    Set wordApp = CreateObject("Word.Application")
    Set wordDoc = wordApp.Documents.Open(ThisWorkbook.Path & "\File_Mau.doc")
    Set wordSelection = wordApp.Selection
    With wordSelection.Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .text = "\[*\]"
        .MatchWildcards = True
        Do While .Execute
            text = wordSelection.text
            If Not dic.exists(text) Then
                dic.Add text, ""
                count = count + 1
                Arr(count, 1) = text
            End If
        Loop
    End With
    If count Then ThisWorkbook.Worksheets("Data").Range("B" & lastRow + 1).Resize(count).Value = Arr
    Set dic = Nothing
    wordDoc.Close False
    Set wordDoc = Nothing
    wordApp.Quit
    Set wordApp = Nothing
End Sub
 
Lần chỉnh sửa cuối:

Cát Lượng

Thành viên thường trực
Tham gia ngày
14 Tháng mười một 2018
Bài viết
319
Được thích
36
Điểm
185
Tuổi
32
Lần sau thì nên làm như chủ chủ đề. Tức đính kèm tập tin và mô tả kỹ yêu cầu. Bắt người khác đọc 100 bài trong chủ đề nào đó và tải hàng loạt tập tin đính kèm để đoán ý tác giả định nói tới bài nào, tập tin nào thì ít ai bỏ công ra giúp. Nhớ nhắc cả bạn Bùi Thúy Thúy ngồi cùng bàn nhé.

Nhìn qua thì như sau, bạn hãy kiểm tra kỹ, bởi tôi không kiểm tra phần thêm KEY này.

Tôi giả thiết là yêu cầu của bạn y như yêu cầu của chủ chủ đề, nhưng thêm phần thêm KEY trong File_Mau.

Code vẫn chỉ có những SUB như bài #6 nhưng thay Sub ChuongTrinh bằng
Mã:
Sub ChuongTrinh()
Dim Arr(), lastRow As Long, k As Long, count As Long, text As String, wordApp As Object, wordDoc As Object, wordSelection As Object, dic As Object
    Application.ScreenUpdating = False
    '''''Kiem tra su ton tai cua File_Mau. Neu khong thay thi Msgbox thong bao va thoat khoi chuong trinh
    With CreateObject("Scripting.FileSystemObject")
        If .FileExists(ThisWorkbook.Path & "\" & "File_Mau.doc") = False Then
            MsgBox "Khong co tap tin File_Mau.doc"
            Exit Sub
        End If
    End With
    Set dic = CreateObject("Scripting.Dictionary")
    dic.comparemode = vbTextCompare
'    ---------- ghi KEY da co vao dic - bat dau ------------
    With ThisWorkbook.Worksheets("Data")
        lastRow = .Cells(Rows.count, "B").End(xlUp).Row
        Arr = .Range("B3:B" & lastRow + 2).Value
    End With
    For k = 1 To UBound(Arr) - 2
        If Arr(k, 1) <> "" Then dic.Add Arr(k, 1), ""
    Next k
'    ---------- ghi KEY da co vao dic - ket thuc ------------
    ReDim Arr(1 To 10000, 1 To 1)
    Set wordApp = CreateObject("Word.Application")
    Set wordDoc = wordApp.Documents.Open(ThisWorkbook.Path & "\File_Mau.doc")
    Set wordSelection = wordApp.Selection
    With wordSelection.Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .text = "\[*\]"
        .MatchWildcards = True
        Do While .Execute
            text = wordSelection.text
            If Not dic.exists(text) Then
                dic.Add text, ""
                count = count + 1
                Arr(count, 1) = text
            End If
        Loop
    End With
    If count Then ThisWorkbook.Worksheets("Data").Range("B" & lastRow + 1).Resize(count).Value = Arr
    Set dic = Nothing
    wordDoc.Close False
    Set wordDoc = Nothing
    wordApp.Quit
    Set wordApp = Nothing
End Sub
Hi dạ! em cám ơn Thầy! thầy vẫn nhớ Bùi Thúy Thúy, hi..
Em có tải file đính kèm luôn ở bài #1 để thực hành
Em đã coppy Sub ChuongTrinh thầy viết dùm ở bài #14 vào và chạy Sub ChuongTrinh đó để lấy [key] từ word sang excel thì đã lấy được [key]
Tiếp đó em chọn tên ô B2 trong sheet_TrangChu để xuất file word mới thì em thấy hiện thông báo lỗi:
Em có tải kèm luôn file em đã thực hành và hình ảnh bị lỗi.
Thầy xem giúp em nhé! em không biết lỗi do đâu, em làm lại 3 lần mà vẫn thông báo lỗi vậy, nếu Sub ChuongTrinh ở bài #6 thì không thấy lỗi nhưng với Sub ChuongTrinh ở bài #14 thì có lỗi thầy ạ!

motaloi_1.pngmo ta loi _2.png
 

File đính kèm

Lần chỉnh sửa cuối:

batman1

Thành viên gắn bó
Tham gia ngày
8 Tháng chín 2014
Bài viết
2,342
Được thích
3,559
Điểm
560
Tiếp đó em chọn tên ô B2 trong sheet_TrangChu để xuất file word mới thì em thấy hiện thông báo lỗi:
Tôi viết rất rõ.
Code vẫn chỉ có những SUB như bài #6 nhưng thay Sub ChuongTrinh bằng
...
Trong bài #6 có ghi
Toàn bộ code của tôi như sau:
Trong Module
...
Trong Module có 2 SUB là Sub ChuongTrinh và Sub createWord. Nhưng trong tập tin của bạn chỉ có Sub ChuongTrinh. Sai là hiển nhiên.
 

Cát Lượng

Thành viên thường trực
Tham gia ngày
14 Tháng mười một 2018
Bài viết
319
Được thích
36
Điểm
185
Tuổi
32
Tôi viết rất rõ.


Trong bài #6 có ghi

Trong Module có 2 SUB là Sub ChuongTrinh và Sub createWord. Nhưng trong tập tin của bạn chỉ có Sub ChuongTrinh. Sai là hiển nhiên.
Vâng, Thầy ơi! Khi xóa từ khóa trong File_Mau đi và lấy [key] sang file excel, các từ khóa bị xóa đi trong File_Mau khi lấy sang file Excel vẫn còn, và nội dung tương ứng với các [key] đã bị xóa đó vẫn còn.
Nếu File_Mau mà có các từ khóa bị xóa đi để chỉnh sửa thì dẫn đến khi lấy [key] sang file excel sẽ thừa [key] và thừa nội dung tương ứng với các [key] đó ở các cột C, cột D...vv... _hình thứ 2
Em làm phiền thầy chút với 02 vấn đề sau:
1/ Khi lấy lại [key] sang file excel, những [key] thừa và nội dung tương ứng với các [key] thừa ở các cột sẽ bị thay thế bởi toàn bộ [key] mới.
2/ Các [key] lấy được điền xuống dòng dưới trong sheet Data mà không theo thứ tự từ đầu trang đến cuối trang trong File_Mau, có thể lấy [key] được theo thứ tự từ đầu trang đến cuối trang như trong File_Mau được không thầy? (như file em đính kèm từ khóa [Anh nguyet] ở vị trí lấy [key] số 09 nhưng khi lấy [key] lại bị đẩy xuống cuối cùng_hình đầu tiên)
Em cám ơn Thầy!
tretre.pngNho thay_1.png
Bài đã được tự động gộp:

Đọc kỹ bài 14.
Tôi không xem file, chỉ xem hình và xem lại bài 6 và tôi biết chắc bạn chưa làm đúng theo hướng dẫn.
Dạ em chỉnh lại rồi nhưng vẫn còn chút xíu vấn đề nữa mà có chạy code mới biết anh ạ! Hy vọng là sẽ hoàn thiện.
 

File đính kèm

Lần chỉnh sửa cuối:

batman1

Thành viên gắn bó
Tham gia ngày
8 Tháng chín 2014
Bài viết
2,342
Được thích
3,559
Điểm
560
Vâng, Thầy ơi! Khi xóa từ khóa trong File_Mau đi và lấy [key] sang file excel, các từ khóa bị xóa đi trong File_Mau khi lấy sang file Excel vẫn còn, và nội dung tương ứng với các [key] đã bị xóa đó vẫn còn.
Nếu File_Mau mà có các từ khóa bị xóa đi để chỉnh sửa thì dẫn đến khi lấy [key] sang file excel sẽ thừa [key] và thừa nội dung tương ứng với các [key] đó ở các cột C, cột D...vv... _hình thứ 2
Bạn hãy suy nghĩ kỹ và nêu hết các yêu cầu. Tôi sẽ chỉ viết cho bạn 1 lần nứa thôi. Tôi không ham trò chơi "Thông tin nhỏ giọt".
 
Lần chỉnh sửa cuối:

Cát Lượng

Thành viên thường trực
Tham gia ngày
14 Tháng mười một 2018
Bài viết
319
Được thích
36
Điểm
185
Tuổi
32
Bạn hãy suy nghĩ kỹ và nêu hết các yêu cầu. Tôi sẽ chỉ viết cho bạn 1 lần nứa thôi. Tôi không ham trò chơi "Thông tin nhỏ giọt".
Bạn hãy suy nghĩ kỹ và nêu hết các yêu cầu. Tôi sẽ chỉ viết cho bạn 1 lần nứa thôi. Tôi không ham trò chơi "Thông tin nhỏ giọt".
Tại em chưa có ý tưởng nên khi chạy code mới phát hiện ra vậy ạ!
Vâng, em cám ơn thầy, vậy nhờ thầy giúp em một lần cuối nhé!
Em tổng hợp mấy vấn đề sau xin được thầy giúp ạ!
1/ Xóa từ khóa trong File_Mau: Khi xóa từ khóa trong File_Mau và lấy lại [Key] mới sang file excel thì những [key] bị xóa trong word cũng tự động bị xóa đi trong excel và các nội dung tương ứng với [key] bị xóa đó ở các cột B, cột C …vv… trong sheet Data của file excel cũng bị xóa .
2/ Thêm từ khóa trong File_Mau: trường hợp thêm từ khóa trong File_Mau thì ở sheet Data những từ khóa và các nội dung tương ứng đã được điền trước đó vẫn được giữ nguyên, từ khóa mới thêm vào ở vị trí nào trong File_Mau thì khi lấy [key] sang file excel theo đúng thứ tự từ trên xuống dưới trong trang File_Mau.
3/ Xuất danh mục văn bản trong file Word mới tạo ra: Khi xuất ra file Word mới có tên như tên chọn trong ô B2 của sheet TrangChu thì có thể xuất tiếp “List danh mục biên bản “ ra file Excel có tên: “List_Tên được chọn trong ô B2 của sheet TrangChu” [có hình đính kèm]

List danh mục này có tên: “List_Tên được chọn trong ô B2 của sheet TrangChu” tạo ra có luật như sau:
Cột “Nội dung văn bản” (Cột B) sẽ lấy các từ có mã màu dạng RGB (0,0,255)
Cột “Số văn bản” (Cột C) sẽ lấy các từ có mã màu dạng RGB (51,51,153)
Cột “Ngày tháng ban hành” (Cột D) sẽ lấy các từ có mã màu dạng RGB (153,0,204) và có định dạng chung.

Theo thứ tự từ đầu đến cuối trang của file word mới được tạo ra thì 03 nội dung tương ứng với 3 mã màu trên chỉ xét trong phạm vi trang đầu tiên xuất hiện cả 03 mã màu đó sẽ tương ứng với số thứ tự là 01 ở cột A , xét tiếp đến trong phạm vi trang thứ 2 chứa cả 03 mã màu đó sẽ tương ứng với số thứ tự 02 và nội dung được điền vào dòng số thứ tự 02 ở các cột B, cột C, cột D trong List_Tên được chọn trong ô B2 của sheet TrangChu .
Số thứ tự được điện tự động theo trình tự xuất hiện của trang trong file word mới xét theo chiều từ đầu đến cuối trang.
(Số thứ tự và nội dung được tạo ra tương ứng với số thứ tự trang trong file word mới mà trang đó phải tính có cả 03 mã màu thì gọi là số thứ tự số 01, xét tiếp trang nào chữa cả 03 mã màu thì gọi là trang thứ 2….theo thứ tự từ đầu đến cuối file Word mới)

Em diễn giải dài dòng quá! thầy giúp em mới ạ!
Em cám ơn Thầy!
097.png
 
Lần chỉnh sửa cuối:
Top Bottom