Xin được sự giúp đỡ chỉnh sửa lại code

Cát Lượng · 21/12/18

Em có vấn đề sau xin được sự giúp đỡ:
Nhấn nút lệnh là "Điền máy thi công" ở sheet "May thi cong" để điền máy thi công vào cột "MÁY MÓC/THIẾT BỊ" (cột H) của sheet "Duong Binh Minh"
Máy thi công được điền vào cột "MÁY MÓC/THIẾT BỊ" (cột H) của sheet "Duong Binh Minh" theo quy luật:
Các từ khóa ở vị trí đầu dòng cột"NỘI DUNG CÔNG VIỆC" (cột D) trong sheet"Duong Binh Minh" tương ứng với từng ngày sẽ được điền bằng tay vào "cột B" của sheet "May thi cong", dữ liệu "cột B" này sẽ được đối chiếu tương ứng với cột C (Tên máy móc) để điền được tên máy thi công tương ứng với nội dung công việc sang cột "MÁY MÓC/THIẾT BỊ" (cột H) của sheet "Duong Binh Minh"
Vấn đề là:
Khi tên máy thi công được điền vào cột "MÁY MÓC/THIẾT BỊ" (cột H) của sheet "Duong Binh Minh" sẽ có tên các máy trùng nhau được điền với số lần >= 2 lần.
Vì các công việc đôi khi cần cùng một loại máy
Em nhờ các anh/chị sửa lại đoạn code có tên là "DungCuThiCong" tương ứng với nút lệnh "Điền máy thi công" ở sheet "May thi cong" để khi điền tên máy thi công thì các máy nào nếu trùng nhau chỉ được điền 1 lần mà không được lặp lại 02 lần (như hình thứ 2)
Code cần sửa :

Mã:

Public Sub DungCuThiCong()
Dim Dic As Object, sArr(), dArr(), tArr(), Rng As Range, Cll As Range, Txt As String
Dim I As Long, N As Long, R1 As Long, R2 As Long, Rws As Long
Set Dic = CreateObject("Scripting.Dictionary")
Set Rng = Sheets("May thi cong").Range("F1", Sheets("May thi cong").Range("F1000").End(xlUp))
tArr = Sheets("May thi cong").Range("B2", Sheets("May thi cong").Range("B2").End(xlDown)).Resize(, 2).Value
R2 = UBound(tArr)
For Each Cll In Rng
    With Sheets(Cll.Value)
            sArr = .Range("C9", .Range("D60000").End(xlUp)).Value
            R1 = UBound(sArr)
            ReDim dArr(1 To R1, 1 To 1)
        For I = 1 To R1
            If sArr(I, 1) <> Empty Then
                Dic.RemoveAll
                Rws = I
            Else
                Txt = sArr(I, 2)
                For N = 1 To R2
                    If Txt Like tArr(N, 1) & "*" Then
                        If Not Dic.Exists(tArr(N, 2)) Then
                            Dic.Item(tArr(N, 2)) = ""
                            dArr(Rws, 1) = dArr(Rws, 1) & "; " & tArr(N, 2)
                        End If
                    End If
                Next N
            End If
        Next I
            For I = 1 To R1
                If Len(dArr(I, 1)) Then
                    dArr(I, 1) = Mid(dArr(I, 1), 3)
                End If
            Next I
        .Range("H9").Resize(R1) = dArr
    End With
Next Cll
MsgBox "Xong!", , "GPE"
Set Dic = Nothing
End Sub

Em xin cảm ơn!

Nhất Chi Lan · 21/12/18

Cát Lượng đã viết:
À cái này tui tải từ thuý thuý gì đó, bạn ý có đăng bài lên, bạn vào bài của bạn ý là có...bạn cứ chia sẻ đi, cho đi sẽ được nhận lại bạn ạ! Mỗi khi ai đó dùng sẽ cảm ơn bạn, mình cũng cảm ơn bạn vì bạn đã chia sẻ và mình cũng là người được kế thừa.

Bạn lại học theo cái Anh hình tượng phật cỡi Mát Đa 6 đó hả. Xin lỗi nha. Vậy mình đi ngủ đây

Cát Lượng · 21/12/18

Nhất Chi Lan đã viết:
Bạn lại học theo cái Anh hình tượng phật cỡi Mát Đa 6 đó hả. Xin lỗi nha. Vậy mình đi ngủ đây

Chịu thôi, bạn lại nghĩ vậy, mình nhờ bạn chứ không năn nỉ để được bạn giúp. Bạn ngủ ngon.

Cát Lượng · 22/12/18

Nhất Chi Lan đã viết:
Bạn lại học theo cái Anh hình tượng phật cỡi Mát Đa 6 đó hả. Xin lỗi nha. Vậy mình đi ngủ đây

Mình làm phiền bạn chút, Mình chạy code "lấy thời tiết từ trang Web" mà bạn viết, thấy báo lỗi, bạn có thể giúp mình chút được không?

tam888 · 22/12/18

Cát Lượng đã viết:
Mình làm phiền bạn chút, Mình chạy code "lấy thời tiết từ trang Web" mà bạn viết, thấy báo lỗi, bạn có thể giúp mình chút được không?

Bài này sao rồi. Cứ đi luận bàn đâu đâu. bài cần không xem

tam888 đã viết:

Trời
Kiểu như áp dụng chơi vậy, liên quan nghề phải cẩn thận
Thử cách củ văn chuối sau:

Mã:

Public Sub DungCuThiCong()
Dim Dic As Object, sArr(), dArr(), tArr(), Rng As Range, Cll As Range, Txt As String
Dim I As Long, N As Long, R1 As Long, R2 As Long, Rws As Long
Set Dic = CreateObject("Scripting.Dictionary")
Set Rng = Sheets("May thi cong").Range("F1", Sheets("May thi cong").Range("F1000").End(xlUp))
tArr = Sheets("May thi cong").Range("B2", Sheets("May thi cong").Range("B2").End(xlDown)).Resize(, 2).Value
R2 = UBound(tArr)
Dim aTxt, tX, sT As String

For Each Cll In Rng
    With Sheets(Cll.Value)
            sArr = .Range("C9", .Range("D60000").End(xlUp)).Value
            R1 = UBound(sArr)
            ReDim dArr(1 To R1, 1 To 1)
        For I = 1 To R1
            If sArr(I, 1) <> Empty Then
                'Dic.RemoveAll
                Rws = I
            Else
                Txt = sArr(I, 2)
                For N = 1 To R2
                    If Txt Like tArr(N, 1) & "*" Then
                        dArr(Rws, 1) = dArr(Rws, 1) & "; " & tArr(N, 2)
                    End If
                Next N
            End If
        Next I
            For I = 1 To R1
                If Len(dArr(I, 1)) Then
                    dArr(I, 1) = Mid(dArr(I, 1), 3)
                    dArr(I, 1) = Replace(dArr(I, 1), ",", ";", , , vbTextCompare)
                    aTxt = Split(dArr(I, 1), ";")
                    sT = ""
                    For Each tX In aTxt
                        If Not Dic.Exists(tX) Then
                            Dic.Add tX, ""
                            sT = sT & "; " & tX
                        End If
                    Next
                    Dic.RemoveAll
                    dArr(I, 1) = Mid(sT, 3)
                End If
            Next I
        .Range("H9").Resize(R1) = dArr
    End With
Next Cll
MsgBox "Xong!", , "GPE"
Set Dic = Nothing
End Sub

Cát Lượng · 22/12/18

tam888 đã viết:
Bài này sao rồi. Cứ đi luận bàn đâu đâu. bài cần không xem

Dạ em cám ơn, em đang trên điện thoại nên chưa test thử được, khi nào ngồi máy em chạy thử.
Chúc anh cuối tuần vui vẻ!

Cát Lượng · 22/12/18

tam888 đã viết:
Bài này sao rồi. Cứ đi luận bàn đâu đâu. bài cần không xem

Anh ơi em vừa chạy thử code anh chỉnh lại giúp em, vẫn còn "tên máy thi công " bị điền 02 lần anh ạ!
Ở bài em test thử: Ô H126 có tên "Máy thủy bình " bị điền 02 lần.
Hic, em ngồi soi thủ công mà vẫn bị điền trùng lặp, anh cho em xin ý kiến mới ạ!
Anh giúp em theo cách "giải pháp chuẩn" mà anh đã nêu ở bài số #04 được không anh?
Em cám ơn anh!

Nhất Chi Lan · 23/12/18

Cát Lượng đã viết:
Mình làm phiền bạn chút, Mình chạy code "lấy thời tiết từ trang Web" mà bạn viết, thấy báo lỗi, bạn có thể giúp mình chút được không?

Code lấy thời tiết vẫn chạy bình thường. Mình chỉnh 1 tẹo trong Code điền thiết bị thôi
Xin đính chính lại là cái Sub getdataweb là do Anh @excel_lv1.5 đã mất rất nhiều công sức viết dùm

Cát Lượng · 23/12/18

Nhất Chi Lan đã viết:
Code lấy thời tiết vẫn chạy bình thường. Mình chỉnh 1 tẹo trong Code điền thiết bị thôi
Xin đính chính lại là cái Sub getdataweb là do Anh @excel_lv1.5 đã mất rất nhiều công sức viết dùm

Cám ơn bạn, mình chạy cái code thời tiết của bạn thấy báo lỗi, lát ngồi máy mình gửi bạn xem lỗi gì giúp mình nhé!

tam888 · 23/12/18

Cát Lượng đã viết:
Mình làm phiền bạn chút, Mình chạy code "lấy thời tiết từ trang Web" mà bạn viết, thấy báo lỗi, bạn có thể giúp mình chút được không?

Cát Lượng đã viết:
Anh ơi em vừa chạy thử code anh chỉnh lại giúp em, vẫn còn "tên máy thi công " bị điền 02 lần anh ạ!
Ở bài em test thử: Ô H126 có tên "Máy thủy bình " bị điền 02 lần.
Hic, em ngồi soi thủ công mà vẫn bị điền trùng lặp, anh cho em xin ý kiến mới ạ!
Anh giúp em theo cách "giải pháp chuẩn" mà anh đã nêu ở bài số #04 được không anh?
Em cám ơn anh!View attachment 209852

Anh giúp em theo cách "giải pháp chuẩn" mà anh đã nêu ở bài số #04 được không anh?
Chuẩn theo bài số 4 thì bạn phải tự làm lại dữ liệu thôi, Mã số định mức, hay khoản mục dự toán thì có quy định quy chuẩn rồi ... bạn hoặc người làm định mức dự toán của bạn phải làm thôi ... mà cái này buộc phải làm trong hồ sơ

Nhất Chi Lan · 23/12/18

tam888 đã viết:
Anh giúp em theo cách "giải pháp chuẩn" mà anh đã nêu ở bài số #04 được không anh?
Chuẩn theo bài số 4 thì bạn phải tự làm lại dữ liệu thôi, Mã số định mức, hay khoản mục dự toán thì có quy định quy chuẩn rồi ... bạn hoặc người làm định mức dự toán của bạn phải làm thôi ... mà cái này buộc phải làm trong hồ sơ

Anh cho em bổ sung cho Bạn ấy cái file Định mức nha Anh

befaint · 23/12/18

Thớt này PHẢI (chứ không phải là "nên") cho vào mục "Thành viên giúp nhau". Nếu không thì khóa nó lại cho đỡ buồn cười vì đã 30 bài rồi.

Cát Lượng · 23/12/18

befaint đã viết:
Thớt này PHẢI (chứ không phải là "nên") cho vào mục "Thành viên giúp nhau". Nếu không thì khóa nó lại cho đỡ buồn cười vì đã 30 bài rồi.

Vâng, Thầy bỏ qua cho em lần này, hỉ... lần sau em sẽ rút kinh nghiệm ạ!

Bài đã được tự động gộp: 23/12/18

Nhất Chi Lan đã viết:
Code lấy thời tiết vẫn chạy bình thường. Mình chỉnh 1 tẹo trong Code điền thiết bị thôi
Xin đính chính lại là cái Sub getdataweb là do Anh @excel_lv1.5 đã mất rất nhiều công sức viết dùm

Vâng, xin cám ơn bạn nhiều!
Các máy thi công khi điền đã không bị trùng, nhưng khi chạy lệnh "Lấy thời tiết từ Web" lại báo lỗi, bạn xem giúp mình ạ!

Bài đã được tự động gộp: 23/12/18

Nhất Chi Lan đã viết:
Anh cho em bổ sung cho Bạn ấy cái file Định mức nha Anh

Anh tam888 ơi? giúp em nhé!
Em cám ơn anh nhìu!

tam888 · 23/12/18

Cát Lượng đã viết:
Anh ơi em vừa chạy thử code anh chỉnh lại giúp em, vẫn còn "tên máy thi công " bị điền 02 lần anh ạ!
Ở bài em test thử: Ô H126 có tên "Máy thủy bình " bị điền 02 lần.
Hic, em ngồi soi thủ công mà vẫn bị điền trùng lặp, anh cho em xin ý kiến mới ạ!
Anh giúp em theo cách "giải pháp chuẩn" mà anh đã nêu ở bài số #04 được không anh?
Em cám ơn anh!View attachment 209852

code sửa lại giải pháp tạm đây:

Mã:

Public Sub DungCuThiCong()
Dim Dic As Object, sArr(), dArr(), tArr(), Rng As Range, Cll As Range, Txt As String
Dim I As Long, N As Long, R1 As Long, R2 As Long, Rws As Long
Set Dic = CreateObject("Scripting.Dictionary")
Set Rng = Sheets("May thi cong").Range("F1", Sheets("May thi cong").Range("F1000").End(xlUp))
tArr = Sheets("May thi cong").Range("B2", Sheets("May thi cong").Range("B2").End(xlDown)).Resize(, 2).Value
R2 = UBound(tArr)
Dim aTxt, tX, sT As String, t As String

For Each Cll In Rng
    With Sheets(Cll.Value)
        sArr = .Range("C9", .Range("D60000").End(xlUp)).Value
        R1 = UBound(sArr)
        ReDim dArr(1 To R1, 1 To 1)
        
        For I = 1 To R1
            If sArr(I, 1) <> Empty Then
                'Dic.RemoveAll
                Rws = I
            Else
                Txt = sArr(I, 2)
                For N = 1 To R2
                    If Txt Like tArr(N, 1) & "*" Then
                        dArr(Rws, 1) = dArr(Rws, 1) & ";" & tArr(N, 2)
                    End If
                Next N
            End If
        Next I
        
        For I = 1 To R1
            If Len(dArr(I, 1)) Then
                dArr(I, 1) = Mid(dArr(I, 1), 2)
                If 1 = 1 Then
                dArr(I, 1) = Replace(dArr(I, 1), ",", ";")
                dArr(I, 1) = Replace(dArr(I, 1), ".", "")
                aTxt = Split(dArr(I, 1), ";")
                sT = ""
                For Each tX In aTxt
                    t = Trim(tX)
                    If Not Dic.Exists(t) Then
                        Dic.Add t, ""
                        sT = sT & "; " & t
                    End If
                Next
                Dic.RemoveAll
                dArr(I, 1) = Mid(sT, 3)
                End If
            End If
        Next I
        
        .Range("H9:H9000").ClearContents
        .Range("H9").Resize(R1) = dArr
    End With
Next Cll
MsgBox "Xong!", , "GPE"
Set Dic = Nothing
End Sub

Cát Lượng · 23/12/18

tam888 đã viết:

code sửa lại giải pháp tạm đây:

Mã:

Public Sub DungCuThiCong()
Dim Dic As Object, sArr(), dArr(), tArr(), Rng As Range, Cll As Range, Txt As String
Dim I As Long, N As Long, R1 As Long, R2 As Long, Rws As Long
Set Dic = CreateObject("Scripting.Dictionary")
Set Rng = Sheets("May thi cong").Range("F1", Sheets("May thi cong").Range("F1000").End(xlUp))
tArr = Sheets("May thi cong").Range("B2", Sheets("May thi cong").Range("B2").End(xlDown)).Resize(, 2).Value
R2 = UBound(tArr)
Dim aTxt, tX, sT As String, t As String

For Each Cll In Rng
    With Sheets(Cll.Value)
        sArr = .Range("C9", .Range("D60000").End(xlUp)).Value
        R1 = UBound(sArr)
        ReDim dArr(1 To R1, 1 To 1)
       
        For I = 1 To R1
            If sArr(I, 1) <> Empty Then
                'Dic.RemoveAll
                Rws = I
            Else
                Txt = sArr(I, 2)
                For N = 1 To R2
                    If Txt Like tArr(N, 1) & "*" Then
                        dArr(Rws, 1) = dArr(Rws, 1) & ";" & tArr(N, 2)
                    End If
                Next N
            End If
        Next I
       
        For I = 1 To R1
            If Len(dArr(I, 1)) Then
                dArr(I, 1) = Mid(dArr(I, 1), 2)
                If 1 = 1 Then
                dArr(I, 1) = Replace(dArr(I, 1), ",", ";")
                dArr(I, 1) = Replace(dArr(I, 1), ".", "")
                aTxt = Split(dArr(I, 1), ";")
                sT = ""
                For Each tX In aTxt
                    t = Trim(tX)
                    If Not Dic.Exists(t) Then
                        Dic.Add t, ""
                        sT = sT & "; " & t
                    End If
                Next
                Dic.RemoveAll
                dArr(I, 1) = Mid(sT, 3)
                End If
            End If
        Next I
       
        .Range("H9:H9000").ClearContents
        .Range("H9").Resize(R1) = dArr
    End With
Next Cll
MsgBox "Xong!", , "GPE"
Set Dic = Nothing
End Sub

Dạ! em cám ơn anh nhiều, khi nào anh có thời gian "nếu có thể" giúp em thêm ý tưởng mà anh đã nêu ở bài #4 nhé!
Ý tưởng đó rất hay và khoa học.
Chúc anh sức khỏe và nhiều may mắn!

tam888 · 23/12/18

Cát Lượng đã viết:
Dạ! em cám ơn anh nhiều, khi nào anh có thời gian "nếu có thể" giúp em thêm ý tưởng mà anh đã nêu ở bài #4 nhé!
Ý tưởng đó rất hay và khoa học.
Chúc anh sức khỏe và nhiều may mắn!

Tiếc là tôi không rảnh và cũng không kham nổi vì:
Và việc đó phải do bạn và nhóm đồng nghiệp của bạn thôi
Tôi không chuyên môn về vấn đề đó nên không động vào, chỉ góp về ý kiến vậy, thấy hay thì các bạn tự làm, không thì bỏ qua

Cát Lượng · 23/12/18

tam888 đã viết:
Tiếc là tôi không rảnh và cũng không kham nổi vì:
Và việc đó phải do bạn và nhóm đồng nghiệp của bạn thôi
Tôi không chuyên môn về vấn đề đó nên không động vào, chỉ góp về ý kiến vậy, thấy hay thì các bạn tự làm, không thì bỏ qua

Vâng, em sẽ nghiên cứu ạ!

befaint · 23/12/18

Bó tay. Thớt này đang vi phạm nội quy vì tiêu đề chung chung.
- Tiêu đề lọc ra được bốn chữ "chỉnh sửa lại code" ==> vậy đã rõ ràng hay chưa????
- Bài 31 đã nêu chủ đề vi phạm mà vẫn có người trả lời bài. Đó, bằng chứng đói bài đấy.

Cát Lượng · 24/12/18

befaint đã viết:
Bó tay. Thớt này đang vi phạm nội quy vì tiêu đề chung chung.
- Tiêu đề lọc ra được bốn chữ "chỉnh sửa lại code" ==> vậy đã rõ ràng hay chưa????
- Bài 31 đã nêu chủ đề vi phạm mà vẫn có người trả lời bài. Đó, bằng chứng đói bài đấy.

Thầy cho em hỏi, giờ có thể chuyển chủ đề để đưa bài đăng này của em từ “ lập trình trong excel “ sang “ thành viên giúp đỡ nhau “ được không ạ?

Xin được sự giúp đỡ chỉnh sửa lại code

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

File đính kèm

Thành viên mới

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

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

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

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

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

File đính kèm

Thành viên mới

File đính kèm

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

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

Thành viên mới

File đính kèm

|||||||||||||

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

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

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

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

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

|||||||||||||

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

Facebook

Group