Lấy số báo cáo tự động bằng VBA

[ĐỨC DIỆN MT]

Kính gửi anh chị,
Em xin nhờ anh chị hỗ trợ viết code thay cho công thức tại cột A và C (file đính kèm)
Cảm ơn anh chị ạ

 

[HieuCD]

Kính gửi anh chị,
Em xin nhờ anh chị hỗ trợ viết code thay cho công thức tại cột A và C (file đính kèm)
Cảm ơn anh chị ạ

Chạy Sub

Sub aBC()
  Dim sArr(), aSTT&(), aBC$(), sRow&, i&
  Dim tDate As Date, tenSP$, stt&, tBC$
 
  With Sheets("Sheet1")
    i = .Range("B" & Rows.Count).End(xlUp).Row
    If i < 3 Then MsgBox ("Khong co du lieu"): Exit Sub
    sArr = .Range("B3:F" & i).Value
    sRow = UBound(sArr)
    ReDim aSTT(1 To sRow, 1 To 1)
    ReDim aBC(1 To sRow, 1 To 1)
    For i = 1 To sRow
      If tDate <> sArr(i, 1) Then
        tDate = sArr(i, 1)
        tenSP = sArr(i, 3)
        tBC = Format(sArr(i, 1), "yymmdd")
        stt = 1
      ElseIf tenSP <> sArr(i, 3) Then
        tenSP = sArr(i, 3)
        stt = stt + 1
      End If
      aSTT(i, 1) = stt
      aBC(i, 1) = tBC & stt & "_" & sArr(i, 5)
    Next i
    .Range("A3").Resize(sRow) = aSTT
    .Range("C3").Resize(sRow) = aBC
  End With
End Sub

 

[ĐỨC DIỆN MT]

Chạy Sub

Sub aBC()
  Dim sArr(), aSTT&(), aBC$(), sRow&, i&
  Dim tDate As Date, tenSP$, stt&, tBC$

  With Sheets("Sheet1")
    i = .Range("B" & Rows.Count).End(xlUp).Row
    If i < 3 Then MsgBox ("Khong co du lieu"): Exit Sub
    sArr = .Range("B3:F" & i).Value
    sRow = UBound(sArr)
    ReDim aSTT(1 To sRow, 1 To 1)
    ReDim aBC(1 To sRow, 1 To 1)
    For i = 1 To sRow
      If tDate <> sArr(i, 1) Then
        tDate = sArr(i, 1)
        tenSP = sArr(i, 3)
        tBC = Format(sArr(i, 1), "yymmdd")
        stt = 1
      ElseIf tenSP <> sArr(i, 3) Then
        tenSP = sArr(i, 3)
        stt = stt + 1
      End If
      aSTT(i, 1) = stt
      aBC(i, 1) = tBC & stt & "_" & sArr(i, 5)
    Next i
    .Range("A3").Resize(sRow) = aSTT
    .Range("C3").Resize(sRow) = aBC
  End With
End Sub

Code hay quá ạ
Anh có thể chỉnh giúp em, khi gõ xong cột "F" mình enter là tự nhảy như công thức, không cần click vào nút và cột "B" tự động lấy ngày nhập không ạ?
Cảm ơn anh!

 

[HieuCD]

Code hay quá ạ
Anh có thể chỉnh giúp em, khi gõ xong cột "F" mình enter là tự nhảy như công thức, không cần click vào nút và cột "B" tự động lấy ngày nhập không ạ?
Cảm ơn anh!

Nhập cột D hoặc cột F code sẽ tự chạy cho 3 cột A B C, mỗi lần chỉ được nhập 1 ô theo trình tự

Private Sub Worksheet_Change(ByVal Target As Range)
  Dim iR&, tDate As Date
 
  If Target.Count = 1 Then
    If Target.Column = 6 Or Target.Column = 4 Then
      iR = Target.Row
      If Cells(iR, 4) <> Empty And Cells(iR, 6) <> Empty Then
        Application.EnableEvents = False
        tDate = Date
        Cells(iR, 2) = tDate
        If tDate <> Cells(iR - 1, 2) Then
          Cells(iR, 1) = 1
        Else
          If Cells(iR, 4) <> Cells(iR - 1, 4) Then
            Cells(iR, 1) = Cells(iR - 1, 1) + 1
          Else
            Cells(iR, 1) = Cells(iR - 1, 1)
          End If
        End If
        Cells(iR, 3) = Format(tDate, "yymmdd") & Cells(iR, 1) & "_" & Cells(iR, 6)
        Application.EnableEvents = True
      End If
    End If
  End If
End Sub

 

[ĐỨC DIỆN MT]

Nhập cột D hoặc cột F code sẽ tự chạy cho 3 cột A B C, mỗi lần chỉ được nhập 1 ô theo trình tự

Private Sub Worksheet_Change(ByVal Target As Range)
  Dim iR&, tDate As Date

  If Target.Count = 1 Then
    If Target.Column = 6 Or Target.Column = 4 Then
      iR = Target.Row
      If Cells(iR, 4) <> Empty And Cells(iR, 6) <> Empty Then
        Application.EnableEvents = False
        tDate = Date
        Cells(iR, 2) = tDate
        If tDate <> Cells(iR - 1, 2) Then
          Cells(iR, 1) = 1
        Else
          If Cells(iR, 4) <> Cells(iR - 1, 4) Then
            Cells(iR, 1) = Cells(iR - 1, 1) + 1
          Else
            Cells(iR, 1) = Cells(iR - 1, 1)
          End If
        End If
        Cells(iR, 3) = Format(tDate, "yymmdd") & Cells(iR, 1) & "_" & Cells(iR, 6)
        Application.EnableEvents = True
      End If
    End If
  End If
End Sub

Tuyệt vời quá
cám ơn anh nhiều ạ