Xin giúp đỡ tự động công việc đánh TEM

[duonghychi]

Chào các anh chị ạ.
Hiện tại, em có 1 file đánh tem hàng ngày, vì không biết công thức và VBA nên công việc khá vất vả ạ. Mong các anh chị giúp đỡ ạ.
Trong file, vùng màu vàng bên phải là danh sách tên sản phẩm ,số lượng mỗi LOT NO, số LOT NO, số lượng bao nhiêu LOT NO.
Bên trái là thông tin trên mỗi TEM ạ.
Mong các anh chị giúp đỡ. Em xin cảm ơn ạ!

 

[HieuCD]

Chào các anh chị ạ.
Hiện tại, em có 1 file đánh tem hàng ngày, vì không biết công thức và VBA nên công việc khá vất vả ạ. Mong các anh chị giúp đỡ ạ.
Trong file, vùng màu vàng bên phải là danh sách tên sản phẩm ,số lượng mỗi LOT NO, số LOT NO, số lượng bao nhiêu LOT NO.
Bên trái là thông tin trên mỗi TEM ạ.
Mong các anh chị giúp đỡ. Em xin cảm ơn ạ!

Chạy code

Sub AddTem()
  Dim sArr(), aTem(1 To 3, 1 To 1)
  Dim i&, n&, j&, r&, c&, d&, k&, eK&
  With Sheets("9")
    i = .Range("AV65000").End(xlUp).Row
    If i < 2 Then MsgBox ("Khong co Tem"): Exit Sub
    sArr = .Range("AS2:AV" & i).Value
    r = 2: c = -3: d = 7: eK = 60
    On Error Resume Next
    For i = 1 To UBound(sArr)
      For j = 1 To 3
        aTem(j, 1) = sArr(i, j)
      Next j
      For n = 1 To sArr(i, 4)
        k = k + 1
        If c < 39 Then c = c + d Else r = r + d: c = 4
        .Cells(r, c).Resize(3) = aTem
      Next n
    Next i
    For i = k + 1 To eK
      If c < 39 Then c = c + d Else r = r + d: c = 4
      If .Cells(r, c).Value = Empty Then Exit For
      .Cells(r, c).Resize(3) = Empty
    Next i
  End With
End Sub

 

[duonghychi]

Chạy code

Sub AddTem()
  Dim sArr(), aTem(1 To 3, 1 To 1)
  Dim i&, n&, j&, r&, c&, d&, k&, eK&
  With Sheets("9")
    i = .Range("AV65000").End(xlUp).Row
    If i < 2 Then MsgBox ("Khong co Tem"): Exit Sub
    sArr = .Range("AS2:AV" & i).Value
    r = 2: c = -3: d = 7: eK = 60
    On Error Resume Next
    For i = 1 To UBound(sArr)
      For j = 1 To 3
        aTem(j, 1) = sArr(i, j)
      Next j
      For n = 1 To sArr(i, 4)
        k = k + 1
        If c < 39 Then c = c + d Else r = r + d: c = 4
        .Cells(r, c).Resize(3) = aTem
      Next n
    Next i
    For i = k + 1 To eK
      If c < 39 Then c = c + d Else r = r + d: c = 4
      If .Cells(r, c).Value = Empty Then Exit For
      .Cells(r, c).Resize(3) = Empty
    Next i
  End With
End Sub

Cảm ơn bác đã giúp đỡ ạ, Có 1 vấn đề nhỏ là số LOT (DATE) em cần tăng lên so với LOT đầu tiên,
VD: D54766, LOT là 01-02-03-04
D53975 LOT là: 05-06-07-08-09-10-11-12
Mong bác giúp đỡ ạ

 

[HieuCD]

Cảm ơn bác đã giúp đỡ ạ, Có 1 vấn đề nhỏ là số LOT (DATE) em cần tăng lên so với LOT đầu tiên,
VD: D54766, LOT là 01-02-03-04
D53975 LOT là: 05-06-07-08-09-10-11-12
Mong bác giúp đỡ ạ

Thêm lệnh tăng Lot
aTem(3, 1) = aTem(3, 1) + 1

Sub AddTem()
  Dim sArr(), aTem(1 To 3, 1 To 1)
  Dim i&, n&, j&, r&, c&, d&, k&, eK&
  With Sheets("9")
    i = .Range("AV65000").End(xlUp).Row
    If i < 2 Then MsgBox ("Khong co Tem"): Exit Sub
    sArr = .Range("AS2:AV" & i).Value
    r = 2: c = -3: d = 7: eK = 60
    On Error Resume Next
    For i = 1 To UBound(sArr)
      For j = 1 To 3
        aTem(j, 1) = sArr(i, j)
      Next j
      For n = 1 To sArr(i, 4)
        k = k + 1
        If c < 39 Then c = c + d Else r = r + d: c = 4
        .Cells(r, c).Resize(3) = aTem
        aTem(3, 1) = aTem(3, 1) + 1
      Next n
    Next i
    For i = k + 1 To eK
      If c < 39 Then c = c + d Else r = r + d: c = 4
      If .Cells(r, c).Value = Empty Then Exit For
      .Cells(r, c).Resize(3) = Empty
    Next i
  End With
End Sub

 

[duonghychi]

Thêm lệnh tăng Lot
aTem(3, 1) = aTem(3, 1) + 1

Sub AddTem()
  Dim sArr(), aTem(1 To 3, 1 To 1)
  Dim i&, n&, j&, r&, c&, d&, k&, eK&
  With Sheets("9")
    i = .Range("AV65000").End(xlUp).Row
    If i < 2 Then MsgBox ("Khong co Tem"): Exit Sub
    sArr = .Range("AS2:AV" & i).Value
    r = 2: c = -3: d = 7: eK = 60
    On Error Resume Next
    For i = 1 To UBound(sArr)
      For j = 1 To 3
        aTem(j, 1) = sArr(i, j)
      Next j
      For n = 1 To sArr(i, 4)
        k = k + 1
        If c < 39 Then c = c + d Else r = r + d: c = 4
        .Cells(r, c).Resize(3) = aTem
        aTem(3, 1) = aTem(3, 1) + 1
      Next n
    Next i
    For i = k + 1 To eK
      If c < 39 Then c = c + d Else r = r + d: c = 4
      If .Cells(r, c).Value = Empty Then Exit For
      .Cells(r, c).Resize(3) = Empty
    Next i
  End With
End Sub

Vâng, em cũng làm như vậy ạ sau 1 hồi nghiên cứu code của bác. Em cảm ơn bác nhiều ạ!