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

[hoctapwme]

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.

 

[Hoàng Tuấn 868]

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.

Thử tham khảo tại đây.

 

[hoctapwme]

Thử tham khảo tại đây.

em vẫn chưa hiểu lắm ạ, bài viết này quy phạm nội dung hay sao anh? do tiêu đề có chữ Help đúng ko ạ? để em chỉnh lại.

 

[HieuCD]

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

 

[hoctapwme]

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

em test tạm thời là rất ổn rồi ạ, cảm ơn anh nhiều.