Chèn dữ liệu từ sheet này qua sheet khác theo điều kiện (1 người xem)

[Thulib]

Em chào Anh/chị trong group ạ
Em đang có một trường hợp muốn chèn dữ liệu từ sheet BTP ( Bán thành phẩm) sang sheet TP ( Thành phẩm) dưới mỗi dòng tô màu vàng ( có code đầu 41*), em đang làm thủ công muốn sảng hồn luôn
Nhờ Anh/chị giúp đỡ em qua con trăng này với ạ.
Em cảm ơn nhiều nhiều ạ

 

[HieuCD]

Em chào Anh/chị trong group ạ
Em đang có một trường hợp muốn chèn dữ liệu từ sheet BTP ( Bán thành phẩm) sang sheet TP ( Thành phẩm) dưới mỗi dòng tô màu vàng ( có code đầu 41*), em đang làm thủ công muốn sảng hồn luôn
Nhờ Anh/chị giúp đỡ em qua con trăng này với ạ.
Em cảm ơn nhiều nhiều ạ

Vụ nầy phải dùng code VBA.
Kiểm tra lại

Option Explicit

Sub xyz()
  Dim TP(), BTP(), res(), dic As Object, dic2 As Object
  Dim sRow&, i&, r&, fR&, eR&, k&, j&, ma$
  Const sR& = 9999 'So dong lon nhat
 
  Set dic = CreateObject("scripting.dictionary")
  Set dic2 = CreateObject("scripting.dictionary")
  With Sheets("BTP")
    BTP = .Range("B2", .Range("J" & sR).End(xlUp).Offset(1)).Value
  End With
  With Sheets("TP")
    TP = .Range("A2", .Range("J" & sR).End(xlUp)).Value
  End With
  ReDim res(1 To sR, 1 To 10)
 
  sRow = UBound(BTP) - 1
  For i = 1 To sRow
    If ma <> BTP(i, 1) And BTP(i, 1) <> Empty Then
      ma = BTP(i, 1)
      fR = i
    End If
    If ma <> BTP(i + 1, 1) Then dic(BTP(i, 1)) = Array(fR, i)
  Next i
 
  sRow = UBound(TP)
  For i = 1 To sRow
    k = k + 1
    For j = 1 To 10
      res(k, j) = TP(i, j)
    Next j
    dic2(TP(i, 5)) = ""
    If dic.exists(TP(i, 5)) Then
      fR = dic(TP(i, 5))(0)
      eR = dic(TP(i, 5))(1)
      For r = fR To eR
        If dic2.exists(BTP(r, 4)) = False Then
          k = k + 1
          For j = 1 To 4
            res(k, j) = TP(i, j)
          Next j
          For j = 5 To 10
            res(k, j) = BTP(r, j - 1)
          Next j
        End If
      Next r
    End If
  Next i
  Sheets("TP").Range("A2").Resize(k, 10) = res
End Sub

 

[Thulib]

Vụ nầy phải dùng code VBA.
Kiểm tra lại

Option Explicit

Sub xyz()
  Dim TP(), BTP(), res(), dic As Object, dic2 As Object
  Dim sRow&, i&, r&, fR&, eR&, k&, j&, ma$
  Const sR& = 9999 'So dong lon nhat
 
  Set dic = CreateObject("scripting.dictionary")
  Set dic2 = CreateObject("scripting.dictionary")
  With Sheets("BTP")
    BTP = .Range("B2", .Range("J" & sR).End(xlUp).Offset(1)).Value
  End With
  With Sheets("TP")
    TP = .Range("A2", .Range("J" & sR).End(xlUp)).Value
  End With
  ReDim res(1 To sR, 1 To 10)
 
  sRow = UBound(BTP) - 1
  For i = 1 To sRow
    If ma <> BTP(i, 1) And BTP(i, 1) <> Empty Then
      ma = BTP(i, 1)
      fR = i
    End If
    If ma <> BTP(i + 1, 1) Then dic(BTP(i, 1)) = Array(fR, i)
  Next i
 
  sRow = UBound(TP)
  For i = 1 To sRow
    k = k + 1
    For j = 1 To 10
      res(k, j) = TP(i, j)
    Next j
    dic2(TP(i, 5)) = ""
    If dic.exists(TP(i, 5)) Then
      fR = dic(TP(i, 5))(0)
      eR = dic(TP(i, 5))(1)
      For r = fR To eR
        If dic2.exists(BTP(r, 4)) = False Then
          k = k + 1
          For j = 1 To 4
            res(k, j) = TP(i, j)
          Next j
          For j = 5 To 10
            res(k, j) = BTP(r, j - 1)
          Next j
        End If
      Next r
    End If
  Next i
  Sheets("TP").Range("A2").Resize(k, 10) = res
End Sub

Ôi code chạy ro ro luôn ạ. Cảm ơn anh nhiều lắm anh ơi ^^

 

[HieuCD]

Ôi code chạy ro ro luôn ạ. Cảm ơn anh nhiều lắm anh ơi ^^

Chỉnh lại code mới chạy an toàn hơn

Option Explicit

Sub xyz()
  Dim TP(), BTP(), res$(), res2(), dic As Object, dic2 As Object
  Dim sRow&, i&, r&, fR&, eR&, k&, j&, ma$
  Const sR& = 9999 'So dong lon nhat
 
  Set dic = CreateObject("scripting.dictionary")
  Set dic2 = CreateObject("scripting.dictionary")
  With Sheets("BTP")
    BTP = .Range("B2", .Range("J" & sR).End(xlUp).Offset(1)).Value
  End With
  With Sheets("TP")
    TP = .Range("A2", .Range("J" & sR).End(xlUp)).Value
  End With
  ReDim res(1 To sR, 1 To 9)
  ReDim res2(1 To sR, 1 To 1)
  sRow = UBound(BTP) - 1
  For i = 1 To sRow
    If ma <> BTP(i, 1) And BTP(i, 1) <> Empty Then
      ma = BTP(i, 1)
      fR = i
    End If
    If ma <> BTP(i + 1, 1) Then dic(BTP(i, 1)) = Array(fR, i)
  Next i
 
  sRow = UBound(TP)
  For i = 1 To sRow
    dic2(TP(i, 2) & "|" & TP(i, 5)) = ""
  Next i
  For i = 1 To sRow
    k = k + 1
    For j = 1 To 9
      res(k, j) = TP(i, j)
    Next j
    res2(k, 1) = TP(i, 10)
    
    If dic.exists(TP(i, 5)) And TP(i, 1) = TP(i, 5) Then
      fR = dic(TP(i, 5))(0)
      eR = dic(TP(i, 5))(1)
      For r = fR To eR
        If dic2.exists(TP(i, 2) & "|" & BTP(r, 4)) = False Then
          k = k + 1
          For j = 1 To 4
            res(k, j) = TP(i, j)
          Next j
          For j = 5 To 9
            res(k, j) = BTP(r, j - 1)
          Next j
          res2(k, 1) = BTP(r, 9)
        End If
      Next r
    End If
  Next i
  With Sheets("TP")
    .Range("A2").Resize(k, 9) = res
    .Range("J2").Resize(k, 1) = res2
  End With
End Sub