Xin giúp code thêm dòng tồn cuối kỳ vào cuối của tháng (1 người xem)

Liên hệ QC

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

Đang trực tuyến: 1 (Thành viên: 0, Khách: 1)
N

ninhtom1

Thành viên hoạt động
Tham gia
26/8/10
Bài viết
106
Được thích
4
Em nhờ các anh chị trên diễn đàn giúp em thêm code VBA vào Sheet THEKHO để cuối tháng nào thì tự chèn được dòng tồn cuối tháng của tháng đó giúp em với ạ. Yêu cầu em có ghi trong Sheet THEKHO. Nhờ các anh chị giúp em với ạ.
 

File đính kèm

Sắp xếp theo thời gian sắp xếp theo bầu chọn
Subtotal

Bạn xem thử file trong khi chờ các cao thủ ra tay
 

File đính kèm

Upvote 0
Tại [B15] của 'TheKho' bạn nhập cụm từ "Tồn cuối " & . . . .

(Nhớ có khoảng trắng ở cuối; Sau đó định dạng Font cho ô này màu trắng;)

Chép đè macro sau đây lên cái cũ & chạy thử x em:

PHP: 
Private Sub Worksheet_Change(ByVal Target As Range)
 If Not Intersect(Target, [b8]) Is Nothing Then
    Dim Sh As Worksheet, Rng As Range, sRng As Range, Cls As Range
    Dim MyAdd As String, ShName As String, jJ As Byte, Dat As Date
       
    [B16].Resize(1500, 7).Clear                     '<=|'
    Columns("IT:IT").ClearContents:                 [it1].Value = "Ngay"
1 'Tao Danh Sach Ngay Duy Nhat:'
    For jJ = 1 To 2
        MyAdd = Choose(jJ, "Nhap", "Xuat")
        Set Sh = ThisWorkbook.Worksheets(MyAdd)
        Set Rng = Sh.Range(Sh.Cells(6, "D"), Sh.[d65500].End(xlUp))
        Rng.NumberFormat = "dd/MM/yyyy"
        Rng.Copy Destination:=[it65500].End(xlUp).Offset(1)
    Next jJ
    Columns("IT:IT").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=[IU1], Unique:=True
    Columns("IU:IU").Sort Key1:=[IU2], Order1:=xlAscending, Header:=xlGuess
2 'Chep Du Lieu Theo Trinh Tu Ngay Thang:'
    For Each Cls In Range([IU2], [IU2].End(xlDown))
        For jJ = 1 To 2
            ShName = Choose(jJ, "Nhap", "Xuat")
            Set Sh = ThisWorkbook.Worksheets(ShName)
            Set Rng = Sh.Range(Sh.[d5], Sh.[d65500].End(xlUp))
            Set sRng = Rng.Find(Cls.Value, , xlFormulas, xlWhole)
            If Not sRng Is Nothing Then
                MyAdd = sRng.Address
                Do
                    If sRng.Offset(, 1).Value = [b8].Value Then
                        With [b1515].End(xlUp).Offset(1)
                    If [b8].Value = "C109" Then
                            .Value = sRng.Value
                            .Offset(, jJ).Value = sRng.Offset(, -1).Value
214                         .Offset(, 3).Value = IIf(jJ = 1, sRng.Offset(, 11 - jJ).Value & " nh" & ChrW(7853) & "p" & sRng.Offset(, 2).Value, " Xu" & ChrW(7845) & "t" & sRng.Offset(, 2).Value & " cho " & sRng.Offset(, 11 - jJ).Value) '<=}'
                            '.Offset(, 4).Value = "Ngay " & IIf(jJ = 1, "N", "X")'
                            .Offset(, 4 + jJ).Value = sRng.Offset(, 4).Value
                            Else
                            .Value = sRng.Value
                            .Offset(, jJ).Value = sRng.Offset(, -1).Value
                            .Offset(, 3).Value = IIf(jJ = 1, sRng.Offset(, 11 - jJ).Value & " nh" & ChrW(7853) & "p", " Xu" & ChrW(7845) & "t cho " & sRng.Offset(, 11 - jJ).Value) '<=}'
                            '.Offset(, 4).Value = "Ngay " & IIf(jJ = 1, "N", "X")'
                            .Offset(, 4 + jJ).Value = sRng.Offset(, 4).Value
                            End If
                        End With
                    End If
                    Set sRng = Rng.FindNext(sRng)
                Loop While Not sRng Is Nothing And sRng.Address <> MyAdd
            End If
        Next jJ
'   *   *   *   *   *   *   *   *'
        If Month(Cls.Value) < Month(Cls.Offset(1).Value) Or (Month(Cls.Value) = 12 And Month(Cls.Offset(1).Value = 1)) Then
            On Error Resume Next
            With [b1515].End(xlUp).Offset(1)
                Dat = DateSerial(Year(.Offset(-1).Value), Month(Cls.Offset(1).Value), 0)
                .Value = Format(Dat, "dd/mm/yyyy")
                .Offset(, 7).Value = .Offset(-1, 7).Value
                .Offset(, 3).Value = [B15].Value & Format(Dat, "dd/mm/yyyy")
                .Offset(, 3).Resize(, 5).Font.Bold = True
            End With
        End If
'   *   *   *   *   *   *   *   *'
    Next Cls
224 Range("B16:b1515").NumberFormat = "dd/MM/yyyy"
   Rng.NumberFormat = "dd/MM/yyyy"
 End If
End Sub
 
Lần chỉnh sửa cuối:
Upvote 0
Cảm ơn anh SA_DQ đã giúp em bài toán này. Sử dụng đoạn code của anh em vẫn còn vướng 1 số vấn đề, nhờ anh giúp em tiếp với.
- Định dạng Ngày tháng tại cột B là căn phải
- Mất định dạng dòng, cột từ cột B-:-H, định dạng font là Times New Roman bị chuyển về .VnTime
- Nếu tháng 1 ko có phát sinh nhập xuất thì nó hiện là: Tồn cuối ngày 30/12/1899 (Đúng ra phải là ngày 31/01/2012)
- Em mới nhập xuất hết tháng 3 mà vật tư nào cũng hiện tồn cuối đến ngày 30/11/2012 ( Đúng ra mới chỉ đến 31/03/2012)
- Có thể chuyển cho em công thức tại cột I và cột A về code VBA được không ạ.
Mong anh giúp em giải quyết các vấn đề trên với. Em xin cảm ơn.
 
Upvote 0
Bạn thử macro sau, khắc fục các iếu điểm cuối

Còn hai vấn đề đầu giành bạn thử sức trước đi!

PHP: 
Private Sub Worksheet_Change(ByVal Target As Range)
 If Not Intersect(Target, [b8]) Is Nothing Then
    Dim Sh As Worksheet, Rng As Range, sRng As Range, Cls As Range
    Dim MyAdd As String, ShName As String, jJ As Byte, Dat As Date, Ngay As Date    '*'
    Dim Nhp As String, Xt As String                 '*'
    
    Nhp = " nh" & ChrW(7853) & "p":                 Xt = " Xu" & ChrW(7845) & "t"
    [B16].Resize(1500, 7).Clear                     '<=|'
    Columns("IT:IT").ClearContents:                 [it1].Value = "Ngay"
1 'Tao Danh Sach Ngay Duy Nhat:'
    For jJ = 1 To 2
        MyAdd = Choose(jJ, "Nhap", "Xuat")
        Set Sh = ThisWorkbook.Worksheets(MyAdd)
        Set Rng = Sh.Range(Sh.Cells(6, "D"), Sh.[d65500].End(xlUp))
        Rng.NumberFormat = "dd/MM/yyyy"
        Rng.Copy Destination:=[it65500].End(xlUp).Offset(1)
    Next jJ
    Columns("IT:IT").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=[IU1], Unique:=True
    Columns("IU:IU").Sort Key1:=[IU2], Order1:=xlAscending, Header:=xlGuess
2 'Chep Du Lieu Theo Trinh Tu Ngay Thang:'
    Ngay = Application.WorksheetFunction.Max(Range([IU2], [IU2].End(xlDown)))
    For Each Cls In Range([IU2], [IU2].End(xlDown))
        For jJ = 1 To 2
            ShName = Choose(jJ, "Nhap", "Xuat")
            Set Sh = ThisWorkbook.Worksheets(ShName)
            Set Rng = Sh.Range(Sh.[d5], Sh.[d65500].End(xlUp))
            Set sRng = Rng.Find(Cls.Value, , xlFormulas, xlWhole)
            If Not sRng Is Nothing Then
                MyAdd = sRng.Address
                Do
                    If sRng.Offset(, 1).Value = [b8].Value Then
                        With [b1515].End(xlUp).Offset(1)
                    If [b8].Value = "C109" Then
                .Value = sRng.Value
                .Offset(, jJ).Value = sRng.Offset(, -1).Value
214             .Offset(, 3).Value = IIf(jJ = 1, sRng.Offset(, 11 - jJ).Value & Nhp & sRng.Offset(, 2).Value, Xt & _
                    sRng.Offset(, 2).Value & " cho " & sRng.Offset(, 11 - jJ).Value)
                .Offset(, 4 + jJ).Value = sRng.Offset(, 4).Value
                    Else
                .Value = sRng.Value
                .Offset(, jJ).Value = sRng.Offset(, -1).Value
                .Offset(, 3).Value = IIf(jJ = 1, sRng.Offset(, 11 - jJ).Value & Nhp, Xt & " cho " & sRng.Offset(, 11 - jJ).Value)
                .Offset(, 4 + jJ).Value = sRng.Offset(, 4).Value
                    End If
                        End With
                    End If
                    Set sRng = Rng.FindNext(sRng)
                Loop While Not sRng Is Nothing And sRng.Address <> MyAdd
            End If
        Next jJ
        
        If Month(Cls.Value) < Month(Cls.Offset(1).Value) Or (Month(Cls.Value) = 12 And Month(Cls.Offset(1).Value = 1)) Then
            On Error GoTo LoiCT
            With [b1515].End(xlUp).Offset(1)
                Dat = DateSerial(Year(Cls.Value), Month(Cls.Offset(1).Value), 0)    '<=|'
                If Month(Dat) > Month(Ngay) Then
                    Dat = DateSerial(Year(Ngay), Month(Ngay), 0)                    '<=|'
                End If
                .Value = Format(Dat, "dd/mm/yyyy")
                .Offset(, 7).Value = .Offset(-1, 7).Value
                .Offset(, 3).Value = [B15].Value & Format(Dat, "dd/mm/yyyy")
                .Offset(, 3).Resize(, 5).Font.Bold = True
            End With
        End If
    Next Cls
224 Range("B16:b1515").NumberFormat = "dd/MM/yyyy"
   Rng.NumberFormat = "dd/MM/yyyy"
 End If
 Exit Sub
LoiCT:
    MsgBox Err, , Error():                          Resume Next
End Sub
 
Upvote 0
Cảm ơn bác nhưng tồn cuối vật tư nào hết 31/03/2012 nó lại hiện là 29/02/2012 là sao? Với bác chuyển cho em công thức cột A và cột I sang code VBA được không ạ.
 
Upvote 0
Bạn kiểm số liệu xem có gì sai không, khi chạy macro sau?

PHP: 
Private Sub Worksheet_Change(ByVal Target As Range)
 If Not Intersect(Target, [b8]) Is Nothing Then
    Dim Sh As Worksheet, Rng As Range, sRng As Range, Cls As Range
    Dim MyAdd As String, ShName As String, jJ As Byte, Dat As Date, Ngay As Date    '*'
    Dim Nhp As String, Xt As String                 '*'
    Const Cho As String = " cho "
    Const SoDg As Long = 1500
    
    Nhp = " nh" & ChrW(7853) & "p":                 Xt = " Xu" & ChrW(7845) & "t"
    [A16].Resize(SoDg, 9).Clear                     '<=|'
    Columns("IT:IT").ClearContents:                 [it1].Value = "Ngay"
1 'Tao Danh Sach Ngay Duy Nhat:'
    For jJ = 1 To 2
        MyAdd = Choose(jJ, "Nhap", "Xuat")
        Set Sh = ThisWorkbook.Worksheets(MyAdd)
        Set Rng = Sh.Range(Sh.Cells(6, "D"), Sh.[d65500].End(xlUp))
        Rng.NumberFormat = "dd/MM/yyyy"
        Rng.Copy Destination:=[it65500].End(xlUp).Offset(1)
    Next jJ
    Columns("IT:IT").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=[IU1], Unique:=True
    Columns("IU:IU").Sort Key1:=[IU2], Order1:=xlAscending, Header:=xlGuess
2 'Chep Du Lieu Theo Trinh Tu Ngay Thang:'
    Ngay = Application.WorksheetFunction.Max(Range([IU2], [IU2].End(xlDown)))
    For Each Cls In Range([IU2], [IU2].End(xlDown))
        For jJ = 1 To 2
            ShName = Choose(jJ, "Nhap", "Xuat")
            Set Sh = ThisWorkbook.Worksheets(ShName)
            Set Rng = Sh.Range(Sh.[d5], Sh.[d65500].End(xlUp))
            Set sRng = Rng.Find(Cls.Value, , xlFormulas, xlWhole)
            If Not sRng Is Nothing Then
                MyAdd = sRng.Address
                Do
                    If sRng.Offset(, 1).Value = [b8].Value Then
                        With Cells(SoDg + 9, "B").End(xlUp).Offset(1)           '*'
                    If [b8].Value = "C109" Then
                        .Offset(, 3).Value = IIf(jJ = 1, sRng.Offset(, 11 - jJ).Value & _
                Nhp & sRng.Offset(, 2).Value, Xt & sRng.Offset(, 2).Value & Cho & sRng.Offset(, 11 - jJ).Value)
                    Else
                        .Offset(, 3).Value = IIf(jJ = 1, sRng.Offset(, 11 - jJ).Value & _
                Nhp, Xt & Cho & sRng.Offset(, 11 - jJ).Value)
                    End If
                .Value = sRng.Value
                .Offset(, -1).Value = 1 + .Offset(-1, -1).Value                 '<=|'
                .Offset(, jJ).Value = sRng.Offset(, -1).Value
                .Offset(, 4 + jJ).Value = sRng.Offset(, 4).Value
                
                .Offset(, 7).Value = .Offset(-1, 7).Value + .Offset(, 5).Value - .Offset(, 6).Value
                
                        End With
                    End If
                    Set sRng = Rng.FindNext(sRng)
                Loop While Not sRng Is Nothing And sRng.Address <> MyAdd
            End If
        Next jJ
        
        If Month(Cls.Value) < Month(Cls.Offset(1).Value) Or (Month(Cls.Value) = 12 And Month(Cls.Offset(1).Value = 1)) _
            Or Cls.Offset(1).Value = "" Then
            On Error GoTo LoiCT
            With [b1515].End(xlUp).Offset(1)
                Dat = DateSerial(Year(Cls.Value), Month(Cls.Offset(1).Value), 0)
                If Month(Dat) > Month(Ngay) Then
                    Dat = DateSerial(Year(Ngay), Month(Ngay), 0)
                End If
                .Value = Dat                                        '<=|'
                .Offset(, -1).Value = 1 + .Offset(-1, -1).Value                 '<=|'
                .Offset(, 7).Value = .Offset(-1, 7).Value
                .Offset(, 3).Value = [B15].Value & Format(Dat, "dd/mm/yyyy")
                .Offset(, 3).Resize(, 5).Font.Bold = True
            End With
        End If
    Next Cls
    Dat = DateSerial(Year(Ngay), Month(Ngay) + 1, 0)                '<=|'
    With [E15].End(xlDown)
        .Value = [B15] & Format$(Dat, "dd/MM/yyyy")
        .Offset(, -3).Value = Dat
    End With                                                        '<=|'
    Range("B16:b1515").NumberFormat = "dd/MM/yyyy"
    Rng.NumberFormat = "dd/MM/yyyy"
 End If
 Exit Sub
LoiCT:
    MsgBox Err, , Error():                          Resume Next
End Sub
 
Upvote 0
Cảm ơn anh đã giúp em, tình hình dữ liệu có vẻ ok rồi, tiện thể giúp cho em cái định dạng font chữ về times new roman, kẻ hàng kẻ cột hộ em với được không.
 
Upvote 0
Bạn phải đăng nhập hoặc đăng ký để trả lời bài viết tại đây.
Web KT

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

P
  • Question Question
Lấy giá trị duy nhất nhiều cột khác nhau (1 người xem)
Trả lời
5
Đọc
150
phamgiang90
P
Q
Phát tiếng khi code chạy ra giá trị yêu cầu
    • Cười
Trả lời
1
Đọc
67
DeTong
D
T
  • Question Question
Xin thầy/cô và anh chị giúp đỡ cách điền thông tin ca kíp trực trong bảng Excel bằng VBA (1 người xem)
Trả lời
1
Đọc
72
HUONGHCKT
H
GPE-Trợ Lý
  • Đã khóa
[GPE] TALK SHOW ĐỊNH KỲ (1 người xem)
    • Thích
    • Yêu thích
    • Cảm ơn
Trả lời
3
Đọc
919
GPE-Trợ Lý
GPE-Trợ Lý
GPE-Trợ Lý
[GPE] TALKSHOW KHÁM PHÁ SỨC MẠNH HÀM FILTER TRONG EXCEL 365 (1 người xem)
    • Thích
Trả lời
2
Đọc
3K
GPE-Trợ Lý
GPE-Trợ Lý
HeSanbi
Office Tool Plus - Ứng dụng tải, cài đặt, gỡ bỏ, nhập khóa, xóa khóa bản quyền Office nhanh chóng (2 người xem)
    • Thích
Trả lời
8
Đọc
351
HeSanbi
HeSanbi
A
  • Question Question
Em nhờ anh/chị/em/chú/bác giúp em viết code tổng hợp dữ liệu. em tính công thức nó nặng quá. em cám ơn (2 người xem)
Trả lời
12
Đọc
269
pycckuu410
pycckuu410
C
Lọc chỉ tiêu sheet 1, kết quả tự động ở các sheet còn lại (2 người xem)
Trả lời
7
Đọc
98
thuytrangbp28
T
D
Tính số lượng nhập vào điều kiện với các code ở thời điểm hiện tại. (1 người xem)
Trả lời
0
Đọc
25
doanlong49
D
HeSanbi
  • Đã giải quyết
WeatherXL - Ứng dụng lấy dữ liệu Thời tiết siêu nhanh (*15/01/2024)
    • Thích
    • Yêu thích
3 4 5
Trả lời
89
Đọc
19K
thuong hau
T
T
Cần hỏi về bảng Table
Trả lời
3
Đọc
57
trungdtbidi
T
Nguyễn Duy Tuân
Lập trình VBA với Google Drive, OneDrive, DropBox cho Upload-Download-Copy-Move...
    • Cảm ơn
Trả lời
3
Đọc
222
Nguyễn Duy Tuân
Nguyễn Duy Tuân
4
EXCEL TỰ ĐỘNG MỞ TRÊN WEB
Trả lời
8
Đọc
206
HeSanbi
HeSanbi
N
Công thức tính điền số lượng lũy kế giao hàng theo điều kiện
Trả lời
0
Đọc
41
Ngocminh19
N
A
Xin các bác chỉ giúp cách thống kê danh sách học sinh (1 người xem)
Trả lời
6
Đọc
124
Anhnn9
A
Việt Nguyễn 86
Excel hay bị tắt đột ngột và hiện trang trắng khi làm việc
Trả lời
7
Đọc
294
Việt Nguyễn 86
Việt Nguyễn 86
cadafi
Hướng dẫn tạo Macro chuyển số thành chữ trong Open Office 3.1 (Tiếng Việt Unicode)
Trả lời
11
Đọc
25K
minnad123
M
T
hỏi về đếm số ngày doanh thu tăng và giảm
Trả lời
5
Đọc
85
VetMini
V
ongke0711
  • Question Question
Trộn dữ liệu từ Excel sang Word mở rộng (phiên bản ongke0711)
    • Thích
    • Yêu thích
    • Cảm ơn
12 13 14
Trả lời
263
Đọc
28K
ongke0711
ongke0711
T
xin công thức tính được số người còn lại theo từng cột
Trả lời
1
Đọc
65
bebo021999
B
Xem thêm…

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

Đếm ngược thời gian

000
Ngày
00
Giờ
00
phút
00
giây
TALKSHOW KHÁM PHÁ SỨC MẠNH HÀM FILTER TRONG EXCEL 365
Back
Top Bottom