Nhờ viết Code VBA chèn nội dung theo điều kiện

Chia sẻ bởi:hands

★★★★★

‹ Demo Form tìm kiếm nhiều cột trong... Cách lấy dữ liệu từ Clipboad vào... ›

Quảng cáo

Chào anh chị trên diễn đàn,

Em đang muốn chèn nội dung từ sheet 1 và sheet 2 khi chương trình quét cột C tại sheet 2 trùng nội dung tại cột B của Sheet 1 thì nó sẽ copy các nội dung con bên trong từ Sheet 1 qua Sheet 2, chèn bên dưới và tự nhân số lượng tương ứng vào luôn.

Em có làm mẫu sẵn, nhờ anh chị xem giúp em code VBA. phần tô màu chỉ là phân biệt, trong code ko cần tô màu.

Em cảm ơn anh chị nhiều.

Kiểm tra lai . .

Option Explicit
Sub XYZ()
  Dim arr(), arr2(), a, res(), dic As Object, key$
  Dim sRow&, sRow2&, i&, fR&, r&, j&, k&, tmp$

Set dic = CreateObject("scripting.dictionary")
  With Sheets("Sheet1")
    i = .Range("C" & Rows.Count).End(xlUp).Row
    If i < 7 Then MsgBox ("Khong co du lieu!"): Exit Sub
    arr = .Range("B6:G" & i + 1).Value
    arr(UBound(arr), 1) = "Ok"
  End With
  sRow = UBound(arr) - 1
  For i = 1 To sRow
    If arr(i, 1) <> Empty Then
      fR = i + 1
      key = arr(i, 1)
    End If
    If arr(i + 1, 1) <> Empty Then dic.Add key, Array(fR, i)
  Next i

With Sheets("Sheet2")
    i = .Range("C" & Rows.Count).End(xlUp).Row
    If i < 5 Then MsgBox ("Khong co du lieu!"): Exit Sub
    arr2 = .Range("B4:I" & i + 1).Value
  End With
  sRow2 = UBound(arr2) - 1
  ReDim res(1 To sRow + sRow2, 1 To 8)
  For i = 1 To sRow2
    k = k + 1
    res(k, 1) = arr2(i, 1): res(k, 2) = arr2(i, 2): res(k, 3) = arr2(i, 3)
    res(k, 4) = arr2(i, 4): res(k, 5) = arr2(i, 5): res(k, 8) = arr2(i, 8)
    If dic.exists(arr2(i, 2)) Then
      a = dic(arr2(i, 2))
      For j = 2 To 5 'Kiem tra da chay code chua?
        If arr2(i + 1, j) <> arr(a(0), j) Then Exit For
      Next j
      If j < 6 Then 'Neu chua chay code
        For r = a(0) To a(1)
          k = k + 1
          res(k, 2) = arr(r, 2): res(k, 3) = arr(r, 3)
          res(k, 4) = arr(r, 4): res(k, 5) = arr(r, 5)
          res(k, 8) = arr(r, 6) * arr2(i, 8)
        Next r
      End If
    End If
  Next i
  Sheets("Sheet2").Range("B4").Resize(k, 8) = res
End Sub