Sữa code tách riêng từng cột và hiện số thập phân trong file theo dõi tồn kho (1 người xem)

luongcongdua · 6/11/25

Nhờ các bác giúp ạ.
E có 1 file mà còn 1 tí vấn đề chưa chưa được tốt lắm. Nhờ các bác giúp e có cách nào sửa lại không ạ.
1. Mỗi số tờ khai nhập nằm ở liên tiếp các cột khác nhau
2. Thể hiên số lẻ ở sau đuôi
Xin cảm ơn ạ!

pycckuu410 · 6/11/25

Vẫn là file hôm nọ đó hả bạn: ChatGPT sửa lại:

PHP:

Sub PhanBo_FIFO_CungSheet_Final_V5()
    On Error GoTo ErrHandler
    Application.ScreenUpdating = False
    Application.EnableEvents = False

    Dim ws As Worksheet
    Set ws = ThisWorkbook.ActiveSheet

    ' --- Cấu hình ---
    Dim startRow As Long: startRow = 4        ' Dòng bắt đầu dữ liệu
    Dim colL As Long: colL = 12               ' Cột L là cột bắt đầu ghi kết quả
    Dim maxColsOut As Long: maxColsOut = 50   ' số ô tối đa cho các phiếu trên cùng 1 dòng

    ' --- Xác định vùng nhập / xuất ---
    Dim lastRowNhap As Long, lastRowXuat As Long
    lastRowNhap = ws.Cells(ws.Rows.Count, "D").End(xlUp).Row
    lastRowXuat = ws.Cells(ws.Rows.Count, "J").End(xlUp).Row

    If lastRowNhap < startRow Or lastRowXuat < startRow Then GoTo CleanExit

    ' --- Đọc dữ liệu nhập ---
    Dim ArrMaNhap As Variant, ArrConLai As Variant
    ArrMaNhap = ws.Range("D" & startRow & ":D" & lastRowNhap).Value
    ArrConLai = ws.Range("E" & startRow & ":F" & lastRowNhap).Value

    Dim i As Long, j As Long
    Dim MaHangXuat As String, MaHangNhap As String
    Dim SLCanLay As Double, SLPhieu As Double
    Dim PhieuID As String
    Dim colWrite As Long

    ' --- Dọn sạch vùng kết quả trước ---
    ws.Range(ws.Cells(startRow, colL), ws.Cells(lastRowXuat, colL + maxColsOut - 1)).ClearContents

    ' --- Duyệt từng dòng xuất theo thứ tự từ trên xuống ---
    For i = startRow To lastRowXuat
        MaHangXuat = Trim(CStr(ws.Cells(i, "J").Value))
        If MaHangXuat = "" Then GoTo NextRow

        If IsNumeric(ws.Cells(i, "K").Value) Then
            SLCanLay = CDbl(ws.Cells(i, "K").Value)
        Else
            SLCanLay = 0
        End If

        colWrite = colL

        ' --- Lấy theo FIFO từ trên xuống ---
        For j = 1 To UBound(ArrMaNhap, 1)
            If SLCanLay <= 0 Then Exit For
            MaHangNhap = Trim(CStr(ArrMaNhap(j, 1)))

            If MaHangNhap = MaHangXuat Then
                Dim SLConLai As Double
                If IsNumeric(ArrConLai(j, 1)) Then
                    SLConLai = CDbl(ArrConLai(j, 1))
                Else
                    SLConLai = 0
                End If

                If SLConLai > 0 Then
                    SLPhieu = WorksheetFunction.Min(SLConLai, SLCanLay)
                    PhieuID = Trim(CStr(ws.Cells(startRow + j - 1, "B").Value))
                    If PhieuID = "" Then PhieuID = "?"

                    ' --- Ghi kết quả: PhieuID: SL ---
                    ws.Cells(i, colWrite).Value = PhieuID & ": " & FormatVietNam(SLPhieu)

                    ' --- Cập nhật tồn và xuất ---
                    ArrConLai(j, 1) = SLConLai - SLPhieu
                    SLCanLay = SLCanLay - SLPhieu
                    colWrite = colWrite + 1
                End If
            End If
        Next j

        ' Nếu chưa đủ hàng để cấp
        If SLCanLay > 0 Then
            ws.Cells(i, colWrite).Value = "(Thiếu " & FormatVietNam(SLCanLay) & ")"
        End If

NextRow:
    Next i

    ' --- Cập nhật tồn cuối ---
    ws.Range("F" & startRow & ":F" & lastRowNhap).Value = ArrConLai

    MsgBox "✅ Phân bổ FIFO hoàn tất theo định dạng Việt Nam.", vbInformation

CleanExit:
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Exit Sub

ErrHandler:
    MsgBox "Lỗi: " & Err.Number & " - " & Err.Description, vbCritical
    Resume CleanExit
End Sub


Function FormatVietNam(ByVal So As Double) As String
    Dim s As String    
    s = Format(So, "#0.00")      

'Lưu ý: Excel của tôi đang để dấu ngăn cách trong công thức là ";", ví dụ: Sum(A1;A2)
    s = Replace(s, ",", "@")   
    s = Replace(s, ".", ",")   
    s = Replace(s, "@", ",")       
    FormatVietNam = s
End Function

HieuCD · 7/11/25

luongcongdua đã viết:
Nhờ các bác giúp ạ.
E có 1 file mà còn 1 tí vấn đề chưa chưa được tốt lắm. Nhờ các bác giúp e có cách nào sửa lại không ạ.
1. Mỗi số tờ khai nhập nằm ở liên tiếp các cột khác nhau
2. Thể hiên số lẻ ở sau đuôi
Xin cảm ơn ạ!

Chạy code . . .

Mã:

Sub xyz()
  Dim aNhap(), aXuat(), aTon(), aTK()
  Dim sNhap&, sXuat&, cCol&, i&, r&, c&, sl#, t#
 
  cCol = 5 'So cot ket qua bang to khai
  i = Range("D" & Rows.Count).End(xlUp).Row
  Range("A3:E" & i).Sort Range("C3"), 1, Header:=xlYes 'Sort du lieu nhap theo ngay
  aNhap = Range("B4:D" & i).Value 'Bang Nhap
  aTon = Range("E4:E" & i).Value 'Ton cuoi
  aXuat = Range("J4", Range("K" & Rows.Count).End(xlUp)).Value 'Bang Xuat
  sNhap = UBound(aNhap): sXuat = UBound(aXuat)
  ReDim aTK(1 To sXuat, 1 To cCol) 'Bang to khai
 
  For i = 1 To sXuat
    If aXuat(i, 2) > 0 Then
      c = 0:      sl = aXuat(i, 2)
      For r = 1 To sNhap
        If aNhap(r, 3) = aXuat(i, 1) Then
          If aTon(r, 1) > 0 Then
            c = c + 1
            If c > UBound(aTK, 2) Then ReDim Preserve aTK(1 To sXuat, 1 To UBound(aTK, 2) + cCol)
            If aTon(r, 1) > sl Then
              aTon(r, 1) = aTon(r, 1) - sl
              aTK(i, c) = aNhap(r, 1) & " = " & sl
              Exit For
            Else
              aTK(i, c) = aNhap(r, 1) & " = " & aTon(r, 1)
              sl = sl - aTon(r, 1)
              aTon(r, 1) = 0
              If sl = 0 Then Exit For
            End If
          End If
        End If
      Next r
    End If
  Next i
  Range("F4").Resize(sNhap) = aTon
  Range("L4").Resize(sXuat, UBound(aTK, 2)) = aTK
End Sub

luongcongdua · 7/11/25

pycckuu410 đã viết:

Vẫn là file hôm nọ đó hả bạn: ChatGPT sửa lại:

PHP:

Sub PhanBo_FIFO_CungSheet_Final_V5()
    On Error GoTo ErrHandler
    Application.ScreenUpdating = False
    Application.EnableEvents = False

    Dim ws As Worksheet
    Set ws = ThisWorkbook.ActiveSheet

    ' --- Cấu hình ---
    Dim startRow As Long: startRow = 4        ' Dòng bắt đầu dữ liệu
    Dim colL As Long: colL = 12               ' Cột L là cột bắt đầu ghi kết quả
    Dim maxColsOut As Long: maxColsOut = 50   ' số ô tối đa cho các phiếu trên cùng 1 dòng

    ' --- Xác định vùng nhập / xuất ---
    Dim lastRowNhap As Long, lastRowXuat As Long
    lastRowNhap = ws.Cells(ws.Rows.Count, "D").End(xlUp).Row
    lastRowXuat = ws.Cells(ws.Rows.Count, "J").End(xlUp).Row

    If lastRowNhap < startRow Or lastRowXuat < startRow Then GoTo CleanExit

    ' --- Đọc dữ liệu nhập ---
    Dim ArrMaNhap As Variant, ArrConLai As Variant
    ArrMaNhap = ws.Range("D" & startRow & ":D" & lastRowNhap).Value
    ArrConLai = ws.Range("E" & startRow & ":F" & lastRowNhap).Value

    Dim i As Long, j As Long
    Dim MaHangXuat As String, MaHangNhap As String
    Dim SLCanLay As Double, SLPhieu As Double
    Dim PhieuID As String
    Dim colWrite As Long

    ' --- Dọn sạch vùng kết quả trước ---
    ws.Range(ws.Cells(startRow, colL), ws.Cells(lastRowXuat, colL + maxColsOut - 1)).ClearContents

    ' --- Duyệt từng dòng xuất theo thứ tự từ trên xuống ---
    For i = startRow To lastRowXuat
        MaHangXuat = Trim(CStr(ws.Cells(i, "J").Value))
        If MaHangXuat = "" Then GoTo NextRow

        If IsNumeric(ws.Cells(i, "K").Value) Then
            SLCanLay = CDbl(ws.Cells(i, "K").Value)
        Else
            SLCanLay = 0
        End If

        colWrite = colL

        ' --- Lấy theo FIFO từ trên xuống ---
        For j = 1 To UBound(ArrMaNhap, 1)
            If SLCanLay <= 0 Then Exit For
            MaHangNhap = Trim(CStr(ArrMaNhap(j, 1)))

            If MaHangNhap = MaHangXuat Then
                Dim SLConLai As Double
                If IsNumeric(ArrConLai(j, 1)) Then
                    SLConLai = CDbl(ArrConLai(j, 1))
                Else
                    SLConLai = 0
                End If

                If SLConLai > 0 Then
                    SLPhieu = WorksheetFunction.Min(SLConLai, SLCanLay)
                    PhieuID = Trim(CStr(ws.Cells(startRow + j - 1, "B").Value))
                    If PhieuID = "" Then PhieuID = "?"

                    ' --- Ghi kết quả: PhieuID: SL ---
                    ws.Cells(i, colWrite).Value = PhieuID & ": " & FormatVietNam(SLPhieu)

                    ' --- Cập nhật tồn và xuất ---
                    ArrConLai(j, 1) = SLConLai - SLPhieu
                    SLCanLay = SLCanLay - SLPhieu
                    colWrite = colWrite + 1
                End If
            End If
        Next j

        ' Nếu chưa đủ hàng để cấp
        If SLCanLay > 0 Then
            ws.Cells(i, colWrite).Value = "(Thiếu " & FormatVietNam(SLCanLay) & ")"
        End If

NextRow:
    Next i

    ' --- Cập nhật tồn cuối ---
    ws.Range("F" & startRow & ":F" & lastRowNhap).Value = ArrConLai

    MsgBox "✅ Phân bổ FIFO hoàn tất theo định dạng Việt Nam.", vbInformation

CleanExit:
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Exit Sub

ErrHandler:
    MsgBox "Lỗi: " & Err.Number & " - " & Err.Description, vbCritical
    Resume CleanExit
End Sub


Function FormatVietNam(ByVal So As Double) As String
    Dim s As String  
    s = Format(So, "#0.00")    

'Lưu ý: Excel của tôi đang để dấu ngăn cách trong công thức là ";", ví dụ: Sum(A1;A2)
    s = Replace(s, ",", "@") 
    s = Replace(s, ".", ",") 
    s = Replace(s, "@", ",")     
    FormatVietNam = s
End Function

đúng rồi ak. em cảm ơn ạ.

Sữa code tách riêng từng cột và hiện số thập phân trong file theo dõi tồn kho (1 người xem)

Người dùng đang xem chủ đề này

luongcongdua

Thành viên mới

File đính kèm

pycckuu410

Thành viên chính thức

HieuCD

Chuyên gia GPE

luongcongdua

Thành viên mới

Bài viết mới nhất

Thành viên có số lượng bài viết cao nhất tháng

Thành viên có điểm tương tác cao nhất tháng

Thời gian đếm ngược.