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

vc_đi chơi · 24/9/19

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 225561 View attachment 225562 View attachment 225563

Bài đã được tự động gộp: 24/9/19

LamNA · 24/9/19

vc_đi chơi đã viết:
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 225561 View attachment 225562 View attachment 225563

Bài đã được tự động gộp: 24/9/19

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 · 24/9/19

LamNA đã viết:
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.

Tôi quên, tôi tải luôn file lên rồi, Bạn giúp tôi mới nhé!

batman1 · 24/9/19

vc_đi chơi đã viết:
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 của bạn có gọi ImportWord và KeyDaTa. Tôi ngại đọc code của người khác nên không dò xem chúng có cần thiết hay không. Nếu chúng còn làm gì đó thì bạn tự thêm vào.

Code không kiểm tra mầu đỏ hay mầu gì. Code coi các KEY có dạng [gì đó]

Sub ChuongTrinh của tôi chỉ làm một việc là lấy các KEY từ Word vào cột B của sheet Data.

Mảng Arr tôi khai báo cho max là 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 · 25/9/19

batman1 đã viết:
Trong Sub ChuongTrinh của bạn có gọi ImportWord và KeyDaTa. Tôi ngại đọc code của người khác nên không dò xem chúng có cần thiết hay không. Nếu chúng còn làm gì đó thì bạn tự thêm vào.

Code không kiểm tra mầu đỏ hay mầu gì. Code coi các KEY có dạng [gì đó]

Sub ChuongTrinh của tôi chỉ làm một việc là lấy các KEY từ Word vào cột B của sheet Data.

Mảng Arr tôi khai báo cho max là 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

batman1 · 25/9/19

vc_đi chơi đã viết:
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?

Bạn có 2 lựa chọn: hoặc nhờ tác giả code của bạn giúp hoặc nhờ tôi. Nếu nhờ tôi thì tôi đập đi xây mới. Tức bạn phải:
1. Mô tả các việc cần làm. Tôi không dò, không nghiên cứu code của người khác để đoán ý bạn.
2. Ý thức được là code của tôi có thể sẽ xung đột với code hiện có của người khác. Bạn có 2 lựa chọn: hoặc xóa hết các code cũ hoặc tự thích ứng chúng với code mới của tôi.

Trước khi làm thì vào Name Manager và xóa hết tất cả những name DMDA - hiện bạn có 2 DMDA. Một rừng name khác có lỗi nhưng tôi không quan tâm. Tự bạn phải vệ sinh gọn gàng tập tin của mình.

Các Key trong Data!B chỉ là chữ không có định dạng gì cả vì chả để làm gì. Phông chữ thì do bạn chọn thôi.

Dòng 2 trong Data phải định dạng là General.

Sub ChuongTrinh sẽ lấy các Key từ Word vào Data!B. Khi Trang Chu Activate code tạo name mới DMDA thích hợp với nội dung hiện hành tại dòng 2 trong Data. Khi chọn B2 ở Trang Chu thì code sẽ thay thế các Key ở Data!B bằng các tên ở cột tương ứng với B2 được chọn và tạo tập tin có tên là B2.

Toàn bộ code củ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

vc_đi chơi · 25/9/19

batman1 đã viết:

Bạn có 2 lựa chọn: hoặc nhờ tác giả code của bạn giúp hoặc nhờ tôi. Nếu nhờ tôi thì tôi đập đi xây mới. Tức bạn phải:
1. Mô tả các việc cần làm. Tôi không dò, không nghiên cứu code của người khác để đoán ý bạn.
2. Ý thức được là code của tôi có thể sẽ xung đột với code hiện có của người khác. Bạn có 2 lựa chọn: hoặc xóa hết các code cũ hoặc tự thích ứng chúng với code mới của tôi.

Trước khi làm thì vào Name Manager và xóa hết tất cả những name DMDA - hiện bạn có 2 DMDA. Một rừng name khác có lỗi nhưng tôi không quan tâm. Tự bạn phải vệ sinh gọn gàng tập tin của mình.

Các Key trong Data!B chỉ là chữ không có định dạng gì cả vì chả để làm gì. Phông chữ thì do bạn chọn thôi.

Dòng 2 trong Data phải định dạng là General.

Sub ChuongTrinh sẽ lấy các Key từ Word vào Data!B. Khi Trang Chu Activate code tạo name mới DMDA thích hợp với nội dung hiện hành tại dòng 2 trong Data. Khi chọn B2 ở Trang Chu thì code sẽ thay thế các Key ở Data!B bằng các tên ở cột tương ứng với B2 được chọn và tạo tập tin có tên là B2.

Toàn bộ code củ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 · 25/9/19

batman1 đã viết:

Bạn có 2 lựa chọn: hoặc nhờ tác giả code của bạn giúp hoặc nhờ tôi. Nếu nhờ tôi thì tôi đập đi xây mới. Tức bạn phải:
1. Mô tả các việc cần làm. Tôi không dò, không nghiên cứu code của người khác để đoán ý bạn.
2. Ý thức được là code của tôi có thể sẽ xung đột với code hiện có của người khác. Bạn có 2 lựa chọn: hoặc xóa hết các code cũ hoặc tự thích ứng chúng với code mới của tôi.

Trước khi làm thì vào Name Manager và xóa hết tất cả những name DMDA - hiện bạn có 2 DMDA. Một rừng name khác có lỗi nhưng tôi không quan tâm. Tự bạn phải vệ sinh gọn gàng tập tin của mình.

Các Key trong Data!B chỉ là chữ không có định dạng gì cả vì chả để làm gì. Phông chữ thì do bạn chọn thôi.

Dòng 2 trong Data phải định dạng là General.

Sub ChuongTrinh sẽ lấy các Key từ Word vào Data!B. Khi Trang Chu Activate code tạo name mới DMDA thích hợp với nội dung hiện hành tại dòng 2 trong Data. Khi chọn B2 ở Trang Chu thì code sẽ thay thế các Key ở Data!B bằng các tên ở cột tương ứng với B2 được chọn và tạo tập tin có tên là B2.

Toàn bộ code củ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?

batman1 · 25/9/19

vc_đi chơi đã viết:
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 lúc bạn chỉ làm được 1 việc. Vậy thì nếu muốn làm việc với Word thì chạy Excel làm gì? Còn nếu muốn làm việc với Excel thì đừng mở Word hoặc đang mở thì đóng. Thế thôi. Cái gì cũ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 · 25/9/19

batman1 đã viết:
Thôi tôi không sửa nữa đâu. Một lúc bạn chỉ làm được 1 việc. Vậy thì nếu muốn làm việc với Word thì chạy Excel làm gì? Còn nếu muốn làm việc với Excel thì đừng mở Word hoặc đang mở thì đóng. Thế thôi. Cái gì cũ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 · 28/9/19

batman1 đã viết:

Bạn có 2 lựa chọn: hoặc nhờ tác giả code của bạn giúp hoặc nhờ tôi. Nếu nhờ tôi thì tôi đập đi xây mới. Tức bạn phải:
1. Mô tả các việc cần làm. Tôi không dò, không nghiên cứu code của người khác để đoán ý bạn.
2. Ý thức được là code của tôi có thể sẽ xung đột với code hiện có của người khác. Bạn có 2 lựa chọn: hoặc xóa hết các code cũ hoặc tự thích ứng chúng với code mới của tôi.

Trước khi làm thì vào Name Manager và xóa hết tất cả những name DMDA - hiện bạn có 2 DMDA. Một rừng name khác có lỗi nhưng tôi không quan tâm. Tự bạn phải vệ sinh gọn gàng tập tin của mình.

Các Key trong Data!B chỉ là chữ không có định dạng gì cả vì chả để làm gì. Phông chữ thì do bạn chọn thôi.

Dòng 2 trong Data phải định dạng là General.

Sub ChuongTrinh sẽ lấy các Key từ Word vào Data!B. Khi Trang Chu Activate code tạo name mới DMDA thích hợp với nội dung hiện hành tại dòng 2 trong Data. Khi chọn B2 ở Trang Chu thì code sẽ thay thế các Key ở Data!B bằng các tên ở cột tương ứng với B2 được chọn và tạo tập tin có tên là B2.

Toàn bộ code củ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!

chothadiem · 28/9/19

batman1 đã viết:

Bạn có 2 lựa chọn: hoặc nhờ tác giả code của bạn giúp hoặc nhờ tôi. Nếu nhờ tôi thì tôi đập đi xây mới. Tức bạn phải:
1. Mô tả các việc cần làm. Tôi không dò, không nghiên cứu code của người khác để đoán ý bạn.
2. Ý thức được là code của tôi có thể sẽ xung đột với code hiện có của người khác. Bạn có 2 lựa chọn: hoặc xóa hết các code cũ hoặc tự thích ứng chúng với code mới của tôi.

Trước khi làm thì vào Name Manager và xóa hết tất cả những name DMDA - hiện bạn có 2 DMDA. Một rừng name khác có lỗi nhưng tôi không quan tâm. Tự bạn phải vệ sinh gọn gàng tập tin của mình.

Các Key trong Data!B chỉ là chữ không có định dạng gì cả vì chả để làm gì. Phông chữ thì do bạn chọn thôi.

Dòng 2 trong Data phải định dạng là General.

Sub ChuongTrinh sẽ lấy các Key từ Word vào Data!B. Khi Trang Chu Activate code tạo name mới DMDA thích hợp với nội dung hiện hành tại dòng 2 trong Data. Khi chọn B2 ở Trang Chu thì code sẽ thay thế các Key ở Data!B bằng các tên ở cột tương ứng với B2 được chọn và tạo tập tin có tên là B2.

Toàn bộ code củ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: 28/9/19

Cát Lượng đã viết:
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 · 28/9/19

Cát Lượng đã viết:
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 · 28/9/19

Cát Lượng đã viết:
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 thì nên làm như chủ chủ đề. Tức đính kèm tập tin và mô tả kỹ yêu cầu. Bắt người khác đọc 100 bài trong chủ đề nào đó và tải hàng loạt tập tin đính kèm để đoán ý tác giả định nói tới bài nào, tập tin nào thì ít ai bỏ công ra giúp. Nhớ nhắc cả bạn Bùi Thúy Thúy ngồi cùng bàn nhé.

Nhìn qua thì như sau, bạn hãy kiểm tra kỹ, bởi tôi không kiểm tra phần thêm KEY này.

Tôi giả thiết là yêu cầu của bạn y như yêu cầu của chủ chủ đề, nhưng thêm phần thêm KEY trong File_Mau.

Code vẫn chỉ có những SUB như bà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

Cát Lượng · 28/9/19

batman1 đã viết:
Lần sau thì nên làm như chủ chủ đề. Tức đính kèm tập tin và mô tả kỹ yêu cầu. Bắt người khác đọc 100 bài trong chủ đề nào đó và tải hàng loạt tập tin đính kèm để đoán ý tác giả định nói tới bài nào, tập tin nào thì ít ai bỏ công ra giúp. Nhớ nhắc cả bạn Bùi Thúy Thúy ngồi cùng bàn nhé.

Nhìn qua thì như sau, bạn hãy kiểm tra kỹ, bởi tôi không kiểm tra phần thêm KEY này.

Tôi giả thiết là yêu cầu của bạn y như yêu cầu của chủ chủ đề, nhưng thêm phần thêm KEY trong File_Mau.

Code vẫn chỉ có những SUB như bà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ớ Bùi Thúy Thú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 ạ!

batman1 · 28/9/19

Cát Lượng đã viết:
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 rõ.

Code vẫn chỉ có những SUB như bài #6 nhưng thay Sub ChuongTrinh bằng
...

Trong bài #6 có ghi

Toàn bộ code của tôi như sau:
Trong Module
...

Trong Module có 2 SUB là Sub ChuongTrinh và Sub createWord. Nhưng trong tập tin của bạn chỉ có Sub ChuongTrinh. Sai là hiển nhiên.

huuthang_bd · 28/9/19

Đọ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.

Cát Lượng · 28/9/19

batman1 đã viết:
Tôi viết rất rõ.

Trong bài #6 có ghi

Trong Module có 2 SUB là Sub ChuongTrinh và Sub createWord. Nhưng trong tập tin của bạn chỉ có Sub ChuongTrinh. Sai là 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!

Bài đã được tự động gộp: 28/9/19

huuthang_bd đã viết:
Đọ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.

batman1 · 28/9/19

Cát Lượng đã viết:
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

Bạn hãy suy nghĩ kỹ và nêu hết các yêu cầu. Tôi sẽ chỉ viết cho bạn 1 lần nứa thôi. Tôi không ham trò chơi "Thông tin nhỏ giọt".

Cát Lượng · 28/9/19

batman1 đã viết:
Bạn hãy suy nghĩ kỹ và nêu hết các yêu cầu. Tôi sẽ chỉ viết cho bạn 1 lần nứa thôi. Tôi không ham trò chơi "Thông tin nhỏ giọ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!

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

Thành viên hoạt động

File đính kèm

Thành viên tích cực

Thành viên hoạt động

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

Thành viên hoạt động

File đính kèm

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

Thành viên hoạt động

Thành viên hoạt động

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

Thành viên hoạt động

Thành viên tiêu biểu

Thành viên hoạt động

Thành viên thường trực

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

Thành viên tiêu biểu

File đính kèm

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

Chuyên gia GPE

Thành viên tiêu biểu

File đính kèm

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

Thành viên tiêu biểu

Facebook

Group