Tạo comment bằng VBA

[tranphuson]

Cho mình hỏi có cách nào tạo Comment cho toàn bộ Sheet "Giao hàng" dựa theo chi tiết ở Sheet "ORDER"

Ví dụ: Ở Cột D4 -> DAT HOA có ngày order là "Thứ 5" thì comment sẽ dựa vào Sheet "Order" theo Thứ

Xin cảm ơn

 

[snow25]

Cho mình hỏi có cách nào tạo Comment cho toàn bộ Sheet "Giao hàng" dựa theo chi tiết ở Sheet "ORDER"

Ví dụ: Ở Cột D4 -> DAT HOA có ngày order là "Thứ 5" thì comment sẽ dựa vào Sheet "Order" theo Thứ

Xin cảm ơn

Bạn chạy thử code dưới xem.

Sub chen()
Dim arr, i As Long, j As Long, dk As String, dic As Object, lr As Long, cm As String
Set dic = CreateObject("scripting.dictionary")
With Sheets("order")
     lr = .Range("C" & Rows.Count).End(xlUp).Row
     If lr < 11 Then Exit Sub
     arr = .Range("B10:m" & lr).Value
     dk = .Range("g8").Value
     For i = 2 To UBound(arr, 1)
         cm = Empty
         For j = 7 To 12
             If dk = arr(i, j) Then
                 cm = dk & ": " & arr(1, j)
                Exit For
             End If
         Next j
         dic.Item(arr(i, 1)) = cm
     Next i
End With
With Sheets("Giao hang")
     lr = .Range("B" & Rows.Count).End(xlUp).Row
     If lr < 4 Then Exit Sub
     .Range("B4:N" & lr).ClearComments
     For j = 3 To 13 Step 2
        For i = 4 To lr
            If .Cells(i, j).Value <> Empty Then
               .Cells(i, j + 1).AddComment
               .Cells(i, j + 1).Comment.Text Text:=dic.Item(.Cells(i, j).Value)
            End If
       Next i
   Next j
End With
End Sub

 

[tranphuson]

Bạn chạy thử code dưới xem.

Sub chen()
Dim arr, i As Long, j As Long, dk As String, dic As Object, lr As Long, cm As String
Set dic = CreateObject("scripting.dictionary")
With Sheets("order")
     lr = .Range("C" & Rows.Count).End(xlUp).Row
     If lr < 11 Then Exit Sub
     arr = .Range("B10:m" & lr).Value
     dk = .Range("g8").Value
     For i = 2 To UBound(arr, 1)
         cm = Empty
         For j = 7 To 12
             If dk = arr(i, j) Then
                 cm = dk & ": " & arr(1, j)
                Exit For
             End If
         Next j
         dic.Item(arr(i, 1)) = cm
     Next i
End With
With Sheets("Giao hang")
     lr = .Range("B" & Rows.Count).End(xlUp).Row
     If lr < 4 Then Exit Sub
     .Range("B4:N" & lr).ClearComments
     For j = 3 To 13 Step 2
        For i = 4 To lr
            If .Cells(i, j).Value <> Empty Then
               .Cells(i, j + 1).AddComment
               .Cells(i, j + 1).Comment.Text Text:=dic.Item(.Cells(i, j).Value)
            End If
       Next i
   Next j
End With
End Sub

Nhân tiện cho mình hỏi thêm là nếu dòng 10 bị "Merge" như file đính kèm thì bị báo lỗi

Cảm ơn

 

[snow25]

Nhân tiện cho mình hỏi thêm là nếu dòng 10 bị "Merge" như file đính kèm thì bị báo lỗi

Cảm ơn

Bạn thay code này nhé.

Sub chen()
Dim arr, i As Long, j As Long, dk As String, dic As Object, lr As Long, cm As String
Set dic = CreateObject("scripting.dictionary")
With Sheets("order")
     lr = .Range("C" & Rows.Count).End(xlUp).Row
     If lr < 11 Then Exit Sub
     arr = .Range("B10:m" & lr).Value
     dk = .Range("g8").Value
     For i = 2 To UBound(arr, 1)
         cm = Empty
         For j = 7 To 12
             If dk = arr(i, j) Then
                 cm = dk & ": " & arr(1, j)
                Exit For
             End If
         Next j
         dic.Item(arr(i, 1)) = cm
     Next i
End With
With Sheets("Giao hang")
     lr = .Range("B" & Rows.Count).End(xlUp).Row
     If lr < 4 Then Exit Sub
     .Range("B4:N" & lr).ClearComments
     For j = 3 To 13 Step 2
        For i = 4 To lr
            If .Cells(i, j).Value <> Empty Then
            If dic.exists(.Cells(i, j).Value) Then
               .Cells(i, j + 1).AddComment
               .Cells(i, j + 1).Comment.Text Text:=dic.Item(.Cells(i, j).Value)
            End If
            End If
       Next i
   Next j
End With
End Sub

 

[tranphuson]

Bạn thay code này nhé.

Sub chen()
Dim arr, i As Long, j As Long, dk As String, dic As Object, lr As Long, cm As String
Set dic = CreateObject("scripting.dictionary")
With Sheets("order")
     lr = .Range("C" & Rows.Count).End(xlUp).Row
     If lr < 11 Then Exit Sub
     arr = .Range("B10:m" & lr).Value
     dk = .Range("g8").Value
     For i = 2 To UBound(arr, 1)
         cm = Empty
         For j = 7 To 12
             If dk = arr(i, j) Then
                 cm = dk & ": " & arr(1, j)
                Exit For
             End If
         Next j
         dic.Item(arr(i, 1)) = cm
     Next i
End With
With Sheets("Giao hang")
     lr = .Range("B" & Rows.Count).End(xlUp).Row
     If lr < 4 Then Exit Sub
     .Range("B4:N" & lr).ClearComments
     For j = 3 To 13 Step 2
        For i = 4 To lr
            If .Cells(i, j).Value <> Empty Then
            If dic.exists(.Cells(i, j).Value) Then
               .Cells(i, j + 1).AddComment
               .Cells(i, j + 1).Comment.Text Text:=dic.Item(.Cells(i, j).Value)
            End If
            End If
       Next i
   Next j
End With
End Sub

Quá tuyệt, đã làm được.

Cảm ơn đã giúp đỡ