Xin giúp code về file thu chi (1 người xem)

[Thành Ares]

Xin chào anh chị và các bạn. Hiện tại mình đang quản lý 1 file excel thu chi tổng hợp. Bây giờ mình muốn khi mình nhập tất cả các khoảng chi trong ngày thì excel tự động copy dữ liệu đó ra từng sheet riêng theo loại. ví dụ lý do chi là vật tư + nhà xưởng thì dữ liệu về vật tư + nhà xưởng sẽ copy hết về 1 sheet VTNX. Rất mong anh chị và các bạn giúp đỡ hoặc có cách nào thì vui lòng cho mình tham khảo với nhé. Thân chào!

 

[killitmore]

Code của bạn nhé, điều kiện là sheet Tổng hợp phải đặt ở vị trí đầu tiên trong file Excel và dữ liệu cột Lý do phải chuẩn (ko thừa dấu cách, thống nhất trong cách ghi cho cùng 1 nội dung )

Sub Macro2()
    ' Initialize for speeding up code
    Application.ScreenUpdating = False
    
    ' Declare vvariables
    Dim source_list As Range, o As Range, lcol As Integer, sh_count As Integer, i As Long, lrow As Long, cur_nrow As Long, sh_name As String
    
    
    'Clear all sheets except sheet tong hop
    sh_count = Worksheets.Count
    On Error Resume Next
    Application.DisplayAlerts = False
    For i = 2 To sh_count
        Sheets(2).Delete
    Next i
    Application.DisplayAlerts = True
    On Error GoTo 0
    
    With Sheets(1)
    ' Create unique list of reasons
        .Range(.Range("C4"), .Range("C4").End(xlDown)).Copy Destination:=.Range("j4")
        .Range(.Range("J4"), .Range("J4").End(xlDown)).RemoveDuplicates Columns:=1, Header:=xlNo
        Set source_list = .Range(.Range("J4"), .Range("J4").End(xlDown))
    ' find the last row and column of source sheet
        lcol = .Range("A3").End(xlToRight).Column
        lrow = .Cells(.Rows.Count, 1).End(xlUp).Row
    End With
    
    'Create list of sheets for unique list of reasons and set up the table for each sheet
    For Each o In source_list
        ActiveWorkbook.Sheets.Add After:=Worksheets(Worksheets.Count)
        ActiveSheet.Name = o.Value
        Sheets(1).Cells(2, 1).Resize(2, lcol).Copy Destination:=Cells(2, 1)
    Next o
    
    'Loop through the source table and move transaction to the corresponding sheet
    With Sheets(1)
        For i = 4 To lrow
            sh_name = CStr(.Cells(i, 3).Value)
            On Error Resume Next
            cur_nrow = Sheets(sh_name).Cells(Rows.Count, 1).End(xlUp).Row + 1
            .Cells(i, 1).Resize(, lcol).Copy Destination:=Sheets(sh_name).Cells(cur_nrow, 1)
            On Error GoTo 0
        Next i
    End With
    
    'Autofit column through all sheets
    sh_count = Worksheets.Count
    For j = 1 To sh_count
        Sheets(j).Columns("A:Z").AutoFit
    Next j
    
    ' Adjust all setting back to normal
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
    
End Sub