code báo cáo tổng hợp từ ngày đến ngày (2 người xem)

  • Thread starter Thread starter DMQ
  • Ngày gửi Ngày gửi
Elx 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)
DMQ

DMQ

Thành viên dốt
Tham gia
21/3/12
Bài viết
722
Được thích
57
Giới tính
Nam
Em có file giả định nhờ các AC giúp viết code báo cáo tổng hợp từ ngày đến ngày. Em xin cám ơn trước.
 
Lần chỉnh sửa cuối:
Sắp xếp theo thời gian sắp xếp theo bầu chọn
Em xin nói rỏ là khi gỏ ngày vào Cell F2(Từ ngày) và H2(Đến ngày) ở sheet"BC" thì sẽ có báo cáo của từng mặt hàng trong khoảng thời gian đó.
 
Upvote 0
DMQ đã viết:
Em xin nói rỏ là khi gỏ ngày vào Cell F2(Từ ngày) và H2(Đến ngày) ở sheet"BC" thì sẽ có báo cáo của từng mặt hàng trong khoảng thời gian đó.
Nhấp chuột vào đây để mở rộng...
Sub này cho sự kiện Change trong sheet BC
PHP: 
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Union([F2], [H2])) Is Nothing Then
   Main
End If
End Sub
Copy hết cái rừng rậm này cho vào 1 Module
PHP: 
Option Explicit
Dim Dic As Object, R As Long
Sub Main()
Dim Data(), Nhap(), Xuat(), StartD As Date, EndD As Date
Data = Sheet4.Range("E4", Sheet4.[I65536].End(3)).Value
ReDim Preserve Data(1 To UBound(Data), 1 To 8)
StartD = Sheet1.[F2].Value: EndD = Sheet1.[H2].Value
Ton Data
Nhap = Sheet2.Range("E4", Sheet2.[K65536].End(3)).Value
Xuat = Sheet3.Range("B4", Sheet3.[J65536].End(3)).Value
XuatNhap Nhap, 4, StartD, EndD, Data
XuatNhap Xuat, 6, StartD, EndD, Data
Sheet1.[C5].Resize(UBound(Data), 8) = Data
End Sub
PHP: 
Sub Ton(Arr)
Set Dic = CreateObject("scripting.dictionary")
For R = 1 To UBound(Arr)
   If Not Dic.exists(Arr(R, 2)) Then
      Dic.Add (Arr(R, 2)), R
   End If
Next
End Sub
PHP: 
Sub XuatNhap(Arr(), Col, A, B, Res())
Dim n As Long, X As Long
n = IIf(Col = 4, 6, 7)
For R = 1 To UBound(Arr)
   If Arr(R, 2) >= A Then
      If Arr(R, 2) <= B Then
         If Dic.exists(Arr(R, Col)) Then
            X = Dic.Item(Arr(R, Col))
            Res(X, n) = Res(X, n) + Arr(R, UBound(Arr, 2))
         End If
      End If
   End If
   Res(R, 8) = Res(R, 5) + Res(R, 6) - Res(R, 7)
Next
End Sub
Ps: Nếu cho công việc thì xài tạm code này, nếu là để nghiên cứu học thì mình khuyên là đừng bao giờ nghiên cứu code của mình. Lu xu bu lắm.
 
Lần chỉnh sửa cuối:
Upvote 0
Nếu được Anh Quang Hai có thể nghiên cứu rút gọn code dùm Ah!!!
 
Upvote 0
Sao em thử thì code chạy lại không đúng. Ở dòng 55 của sheet:BC" trở xuống có "tồn đầu","nhập","xuất" mà không có cột"Tồn Cuối". Mong Anh xem lại giúp em!!!!
 
Upvote 0
Macro này dễ hiểu hơn nè;

Bạn kiểm tiếp xem sao
 

File đính kèm

Upvote 0
DMQ đã viết:
Sao em thử thì code chạy lại không đúng. Ở dòng 55 của sheet:BC" trở xuống có "tồn đầu","nhập","xuất" mà không có cột"Tồn Cuối". Mong Anh xem lại giúp em!!!!
Nhấp chuột vào đây để mở rộng...
Sửa lại tẹo. Code ẩu quá
PHP: 
Option Explicit
Dim Dic As Object, R As Long
Sub Main()
Dim Data(), Nhap(), Xuat(), StartD As Date, EndD As Date
Data = Sheet4.Range("E4", Sheet4.[I65536].End(3)).Value
ReDim Preserve Data(1 To UBound(Data), 1 To 8)
StartD = Sheet1.[F2].Value: EndD = Sheet1.[H2].Value
Ton Data
Nhap = Sheet2.Range("E4", Sheet2.[K65536].End(3)).Value
Xuat = Sheet3.Range("B4", Sheet3.[J65536].End(3)).Value
XuatNhap Nhap, 4, StartD, EndD, Data
XuatNhap Xuat, 6, StartD, EndD, Data
For R = 1 To UBound(Data)
   Data(R, 8) = Data(R, 5) + Data(R, 6) - Data(R, 7)
Next
Sheet1.[C5].Resize(UBound(Data), 8) = Data
End Sub
Sub Ton(Arr)
Set Dic = CreateObject("scripting.dictionary")
For R = 1 To UBound(Arr)
   If Not Dic.exists(Arr(R, 2)) Then
      Dic.Add (Arr(R, 2)), R
   End If
Next
End Sub
Sub XuatNhap(Arr(), Col, A, B, Res())
Dim n As Long, X As Long
n = IIf(Col = 4, 6, 7)
For R = 1 To UBound(Arr)
   If Arr(R, 2) >= A Then
      If Arr(R, 2) <= B Then
         If Dic.exists(Arr(R, Col)) Then
            X = Dic.Item(Arr(R, Col))
            Res(X, n) = Res(X, n) + Arr(R, UBound(Arr, 2))
         End If
      End If
   End If
Next
End Sub
 
Upvote 0
Mã: 
[COLOR=#000000][I]Option Explicit[/I][/COLOR]


[COLOR=#000000][I]Sub bcth()[/I][/COLOR]
[COLOR=#000000][I]On Error Resume Next[/I][/COLOR]
[COLOR=#000000][I]Dim ArrN(), ArrX(), MS(), Kq(), ID, i, j, s, bd, kd, Dic As Object[/I][/COLOR]
[COLOR=#000000][I]Set Dic = CreateObject("Scripting.Dictionary")[/I][/COLOR]
[COLOR=#000000][I]Sheet2.AutoFilterMode = False[/I][/COLOR]
[COLOR=#000000][I]Sheet3.AutoFilterMode = False[/I][/COLOR]
[COLOR=#000000][I]Sheet4.AutoFilterMode = False[/I][/COLOR]
[COLOR=#000000][I]Sheet1.Range("C5:J72").ClearContents[/I][/COLOR]
[COLOR=#000000][I]bd = Sheet1.Range("F2").Value[/I][/COLOR]
[COLOR=#000000][I]kd = Sheet1.Range("H2").Value[/I][/COLOR]
[COLOR=#000000][I]MS = Sheet4.Range("F4:I" & Sheet4.Range("F65000").End(3).Row).Value[/I][/COLOR]
[COLOR=#000000][I]ArrN = Sheet2.Range("E4:K" & Sheet2.Range("E65000").End(3).Row).Value[/I][/COLOR]
[COLOR=#000000][I]ArrX = Sheet3.Range("B4:J" & Sheet3.Range("B65000").End(3).Row).Value[/I][/COLOR]
[COLOR=#000000][I]ReDim Kq(1 To Sheet4.Range("F65000").End(3).Row, 1 To 11)[/I][/COLOR]

[COLOR=#000000][I]For i = 1 To UBound(MS, 1)[/I][/COLOR]
[COLOR=#000000][I]If MS(i, 1) <> "" Then[/I][/COLOR]
[COLOR=#000000][I]s = s + 1[/I][/COLOR]
[COLOR=#000000][I]Dic.Add CStr(MS(i, 1)), s[/I][/COLOR]
[COLOR=#000000][I]Kq(s, 1) = s[/I][/COLOR]
[COLOR=#000000][I]Kq(s, 2) = MS(i, 1)[/I][/COLOR]
[COLOR=#000000][I]Kq(s, 3) = MS(i, 2)[/I][/COLOR]
[COLOR=#000000][I]Kq(s, 4) = MS(i, 3)[/I][/COLOR]
[COLOR=#000000][I]Kq(s, 9) = MS(i, 4)[/I][/COLOR]
[COLOR=#000000][I]End If[/I][/COLOR]
[COLOR=#000000][I]Next i[/I][/COLOR]


[COLOR=#000000][I]For i = 1 To UBound(ArrN)[/I][/COLOR]
[COLOR=#000000][I]ID = Dic.Item(CStr(ArrN(i, 4)))[/I][/COLOR]
[COLOR=#000000][I]If ArrN(i, 2) < bd Then[/I][/COLOR]
[COLOR=#000000][I]Kq(ID, 10) = Kq(ID, 10) + ArrN(i, 7)[/I][/COLOR]
[COLOR=#000000][I]ElseIf ArrN(i, 2) >= bd And ArrN(i, 2) <= kd Then[/I][/COLOR]
[COLOR=#000000][I]Kq(ID, 6) = Kq(ID, 6) + ArrN(i, 7)[/I][/COLOR]
[COLOR=#000000][I]End If[/I][/COLOR]

[COLOR=#000000][I]Next i[/I][/COLOR]


[COLOR=#000000][I]For i = 1 To UBound(ArrX)[/I][/COLOR]
[COLOR=#000000][I]ID = Dic.Item(CStr(ArrX(i, 6)))[/I][/COLOR]
[COLOR=#000000][I]If ArrX(i, 2) < bd Then[/I][/COLOR]
[COLOR=#000000][I]Kq(ID, 11) = Kq(ID, 11) + ArrX(i, 9)[/I][/COLOR]
[COLOR=#000000][I]ElseIf ArrX(i, 2) >= bd And ArrX(i, 2) <= kd Then[/I][/COLOR]
[COLOR=#000000][I]Kq(ID, 7) = Kq(ID, 7) + ArrX(i, 9)[/I][/COLOR]
[COLOR=#000000][I]End If[/I][/COLOR]
[COLOR=#000000][I]Next i[/I][/COLOR]


[COLOR=#000000][I]For i = 1 To UBound(Kq)[/I][/COLOR]
[COLOR=#000000][I]Kq(i, 5) = Kq(i, 9) + Kq(i, 10) - Kq(i, 11)[/I][/COLOR]
[COLOR=#000000][I]Kq(i, 8) = Kq(i, 5) + Kq(i, 6) - Kq(i, 7)[/I][/COLOR]
[COLOR=#000000][I]Next i[/I][/COLOR]




[COLOR=#000000][I]If s > 0 Then Sheet1.Range("C5:J5").Resize(s) = Kq[/I][/COLOR]
[COLOR=#000000][I]Set Dic = Nothing[/I][/COLOR]
[COLOR=#000000][I]Erase ArrN(), ArrX(), MS(), Kq()[/I][/COLOR]


[COLOR=#000000][I]End Sub[/I][/COLOR]


E Mới bắt đầu với dic nên phải chơi đến 4 vòng lặp!$@!!!$@!!!$@!!!$@!!

đưa lên để đc góp ý %#^#$%#^#$%#^#$%#^#$
 
Upvote 0
DMQ đã viết:
Nếu được Anh Quang Hai có thể nghiên cứu rút gọn code dùm Ah!!!
Nhấp chuột vào đây để mở rộng...
Muốn gọn thì cho gọn, nhưng nhìn code không có "bờ rồ". Thay hết cái rừng kia bằng cái rừng này
Không xài vòng lặp nào cả.
PHP: 
Sub XNT()
   Sheet1.[C5].CurrentRegion.Offset(1).ClearContents
   Sheet4.Range("E4", Sheet4.[I65536].End(3)).Copy Sheet1.[C5]
   With Sheet1.Range("G5", Sheet1.[G65536].End(3))
      .Offset(, 1).SpecialCells(4).Formula = _
      "=SUMPRODUCT((CTN!R4C8:R1000C8=RC4)*(CTN!R4C6:R1000C6>=R2C6)" _
      & "*(CTN!R4C6:R1000C6<=R2C8)*(CTN!R4C11:R1000C11))"
      .Offset(, 2).SpecialCells(4) = _
      "=SUMPRODUCT((CTX!R4C7:R1000C7=RC4)*(CTX!R4C3:R1000C3>=R2C6)" _
      & "*(CTX!R4C3:R1000C3<=R2C8)*(CTX!R4C10:R1000C10))"
       .Offset(, 3).SpecialCells(4) = "=RC[-3]+RC[-2]-RC[-1]"
       .Offset(, 1).Resize(, 3).Value = .Offset(, 1).Resize(, 3).Value
   End With
End Sub
 
Lần chỉnh sửa cuối:
Upvote 0
Anh Quang Hai có thể giúp em trong sự kiện Worksheet_change khi gỏ ngày của "Đến ngày-H2" mà nhỏ hơn "Từ ngày-F2" thì không cho(như hiện MsgBox báo lỗi). Anh cho em hỏi (ngoài lề) sao code trong bài #9 của Anh sử dụng công thức mà khi em chọn vào cell lại không hiện công thức trên thanh Fomula.(Vì em thấy có những đoạn code sử dụng công thức thì hiện công thức trên thanh fomula)
 
Upvote 0
Thay mặt anh Hải (câu này cũng dễ --=0) mình xin trả lời bạn:

DMQ đã viết:
Anh Quang Hai có thể giúp em trong sự kiện Worksheet_change khi gỏ ngày của "Đến ngày-H2" mà nhỏ hơn "Từ ngày-F2" thì không cho(như hiện MsgBox báo lỗi).
Nhấp chuột vào đây để mở rộng...

Mã: 
Private Sub Worksheet_Change(ByVal Target As Range)If Not Intersect(Target, Union([F2], [H2])) Is Nothing Then
[COLOR=#ff0000]If [H2] >= [F2] Then[/COLOR]
[COLOR=#ff0000]   Main[/COLOR]
[COLOR=#ff0000]Else[/COLOR]
[COLOR=#ff0000]    MsgBox "Den ngay phai lon hon hoac bang tu ngay"[/COLOR]
End If
End If
End Sub
Đoạn màu đỏ là thêm điều kiện vào.
DMQ đã viết:
Anh cho em hỏi (ngoài lề) sao code trong bài #9 của Anh sử dụng công thức mà khi em chọn vào cell lại không hiện công thức trên thanh Fomula.(Vì em thấy có những đoạn code sử dụng công thức thì hiện công thức trên thanh fomula)
Nhấp chuột vào đây để mở rộng...

Trong code có đoạn này:

Mã: 
[COLOR=#007700][FONT=monospace].[/FONT][/COLOR][COLOR=#0000BB][FONT=monospace]Offset[/FONT][/COLOR][COLOR=#007700][FONT=monospace](, [/FONT][/COLOR][COLOR=#0000BB][FONT=monospace]1[/FONT][/COLOR][COLOR=#007700][FONT=monospace]).[/FONT][/COLOR][COLOR=#0000BB][FONT=monospace]Resize[/FONT][/COLOR][COLOR=#007700][FONT=monospace](, [/FONT][/COLOR][COLOR=#0000BB][FONT=monospace]3[/FONT][/COLOR][COLOR=#007700][FONT=monospace]).[/FONT][/COLOR][COLOR=#0000BB][FONT=monospace]Value [/FONT][/COLOR][COLOR=#007700][FONT=monospace]= .[/FONT][/COLOR][COLOR=#0000BB][FONT=monospace]Offset[/FONT][/COLOR][COLOR=#007700][FONT=monospace](, [/FONT][/COLOR][COLOR=#0000BB][FONT=monospace]1[/FONT][/COLOR][COLOR=#007700][FONT=monospace]).[/FONT][/COLOR][COLOR=#0000BB][FONT=monospace]Resize[/FONT][/COLOR][COLOR=#007700][FONT=monospace](, [/FONT][/COLOR][COLOR=#0000BB][FONT=monospace]3[/FONT][/COLOR][COLOR=#007700][FONT=monospace]).[/FONT][/COLOR][COLOR=#0000BB][FONT=monospace]Value[/FONT][/COLOR]

Mục đích là chuyển công thức thành Value đấy bạn ạ.
 
Lần chỉnh sửa cuối:
Upvote 0
Bạn mhung12005 có thể cho mình hỏi ngoài lề chút nhe, sao cũng file đó mà copy qua máy khác thì lỗi Name ở CT vậy bạn. Mặc dù file đó chạy ngon lành ở máy mình. Mình nghĩ có thể định dạng máy kia khác mà mình chỉnh về cùng định dạng vẫn bị lỗi Name.
 
Upvote 0
DMQ đã viết:
Bạn mhung12005 có thể cho mình hỏi ngoài lề chút nhe, sao cũng file đó mà copy qua máy khác thì lỗi Name ở CT vậy bạn. Mặc dù file đó chạy ngon lành ở máy mình. Mình nghĩ có thể định dạng máy kia khác mà mình chỉnh về cùng định dạng vẫn bị lỗi Name.
Nhấp chuột vào đây để mở rộng...

Bạn thử đưa file lỗi đó lên xem nào, nói vậy thì khó quá. Giống như khám bệnh kiểu miêu tả ý :D
 
Upvote 0
Xin lỗi Anh QuangHai, vì file giả định của em đưa lên có 1 tháng nên Code Anh viết(bài#9) bị sai. Ý của em là khi báo cáo thì cột "Tồn đầu kỳ' sẽ là số lượng của "Tồn cuối kỳ" của tháng trước đó. ví dụ như xem "nhãn các loại" của ngày'1/2/2014" đến ngày"28/2/2014" thì "Tồn đầu kỳ" sẽ là số lượng của" tồn cuối kỳ" của tháng 1/2014. Mong Anh xem lại giúp em!!!!!
 
Upvote 0
Em đưa file mới lên có 03 tháng mong các AC giúp em báo cáo theo từ ngày đến ngày. Em xin giải thích thêm là "Tồn đầu kỳ" là số lương tốn tới ngày gần kề liến với ngày "Từ Ngày" , "nhập trong kỳ" là số lượng nhập trong khoảng >="Từ Ngày" đến <="Đến ngày", "Xuất trong kỳ" là số lượng xuất trong khoảng >="Từ ngày" đến <="đến ngày", "Tốn cuối kỳ bằng :"tồn đầu kỳ" cộng "nhập trong kỳ" trừ "xuất trong kỳ". ví dụ như báo cáo từ ngày 1/2/2014 đến ngày 28/2/2014 thì "tồn đầu kỳ" của tháng 2 là số lượng "tồn cuối kỳ" của tháng 1. Mong các Ac giúp đỡ!!!!
 

File đính kèm

Upvote 0
Với cơ sở dữ liệu của post#1 thì bạn tham khảo #8 ,bạn thay đổi ngày rồi chạy code xem chính xác chưa, mình làm theo cách bạn vừa nói đấy
 
Upvote 0
Bài #6 đã làm được như vậy rồi mà, chỉ tội rùa 1 tẹo.

[Thongbao]Em đưa file mới lên có 03 tháng mong các AC giúp em báo cáo theo từ ngày đến ngày. Em xin giải thích thêm là "Tồn đầu kỳ" là số lương tốn tới ngày gần kề liến với ngày "Từ Ngày" , "nhập trong kỳ" là số lượng nhập trong khoảng >="Từ Ngày" đến <="Đến ngày", "Xuất trong kỳ" là số lượng xuất trong khoảng >="Từ ngày" đến <="đến ngày", "Tốn cuối kỳ bằng :"tồn đầu kỳ" cộng "nhập trong kỳ" trừ "xuất trong kỳ". ví dụ như báo cáo từ ngày 1/2/2014 đến ngày 28/2/2014 thì "tồn đầu kỳ" của tháng 2 là số lượng "tồn cuối kỳ" của tháng 1. Mong các Ac giúp đỡ!!!![/Thongbao]

Thay vì .02 gy thì là .2 gy.
 
Upvote 0
Code của Bạn HYen17 hơi chậm vì dữ liệu mình nhiều (bạn nói "Thay vì .02 gy thì là .2 gy."--mình không hiểu.) còn của bạn boidaigai mình dang thử . Mong có AC nào tham gia viết code cho nhanh!!!
 
Upvote 0
Bạn phải đăng nhập hoặc đăng ký để trả lời bài viết tại đây.

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

L
Tính thời gian làm việc thực tế
Trả lời
66
Đọc
14K
YenTon
Y
H
Chia sẻ file in Phiếu điều tra PCGD
    • Thích
    • Yêu thích
    • Cảm ơn
Trả lời
13
Đọc
630
Phuong7686
P
GPE-Trợ Lý
  • Dán lên cao
[KHẨN] HƯỚNG VỀ ĐỒNG BÀO CHỊU ẢNH HƯỞNG CỦA BÃO YAGI - BẢO YÊN, LÀO CAI (2 người xem)
    • Thích
    • Cảm ơn
    • Yêu thích
Trả lời
91
Đọc
14K
SA_DQ
SA_DQ
SA_DQ
Copilot bình luận về một ván cờ vua (1 người xem)
    • Thích
Trả lời
6
Đọc
409
SA_DQ
SA_DQ
92nguyenthanh
  • Question Question
Vba cho file nhập xuất kho (1 người xem)
Trả lời
4
Đọc
110
HUONGHCKT
H
C
Fix lỗi Application.InputBox Type:=8
    • Cười
Trả lời
25
Đọc
618
ptm0412
ptm0412
GPE-Trợ Lý
[GPE] TALK SHOW 08: GIẢI QUYẾT VẤN ĐỀ TỐI ƯU HÓA TRONG EXCEL VỚI CÔNG CỤ SOLVER
    • Thích
    • Cảm ơn
Trả lời
4
Đọc
3K
DuongLeHung
D
Gà Công Nghệ
Chế độ chính sách cho giáo viên mầm non giữ trẻ khuyết tật
Trả lời
1
Đọc
58
vanle33
vanle33
huuthang_bd
Add-in DeleteVirusMacro - Xóa và ngăn chặn virus macro
    • Thích
    • Yêu thích
    • Cảm ơn
Trả lời
56
Đọc
22K
dunghtgiga
dunghtgiga
L
  • Question Question
Viết code tìm kiếm các file trong Folder
Trả lời
40
Đọc
12K
lan nguyen0987
L
P
Hyperlink_Cách chuyển cả thư mục và file tổng hợp sang máy khác không bị lỗi
Trả lời
5
Đọc
109
phongvanvu
P
HeSanbi
Tiện ích Web: Tự động nhấn nút "Bỏ qua" quảng cáo Youtube
    • Thích
    • Yêu thích
Trả lời
14
Đọc
1K
ongke0711
ongke0711
ptm0412
Quá tin tưởng vào AI các thể loại
    • Cười
Trả lời
4
Đọc
218
Maika8008
Maika8008
A
  • Question Question
Không tìm được lỗi code
Trả lời
6
Đọc
159
ptm0412
ptm0412
W
Tham chiếu theo chuỗi ký tự
Trả lời
8
Đọc
315
dungpham01
D
tritv.dad
Lấy dữ liệu từ folder các tờ khai thông quan để theo dõi hiệu suất công việc.
Trả lời
8
Đọc
287
BlueSphere
B
GPE-Trợ Lý
MỪNG NGÀY NHÀ GIÁO VIỆT NAM 20/11 (2 người xem)
    • Thích
Trả lời
0
Đọc
3K
GPE-Trợ Lý
GPE-Trợ Lý
SA_DQ
Xin chúc mừng các thầy cô giáo trên cộng đồng nhân 20/11
    • Thích
    • Yêu thích
Trả lời
1
Đọc
135
BuiQuangThuan
B
M
chuyển đổi số thành chữ
Trả lời
15
Đọc
371
dungpham01
D
V
Lỗi copy sheet: the name already exists.
Trả lời
7
Đọc
702
nghiabros
N
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

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

000
Ngày
00
Giờ
00
phút
00
giây
Thân mời tham dự sự kiện sinh nhật GPE 2025
Back
Top Bottom