Nhờ anh, chị lập giúp code VBA cho dòng cộng và tổng cộ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)
H

hoangminh2018

Thành viên chính thức
Tham gia
31/10/18
Bài viết
58
Được thích
4
Em có file này trước đây có một anh trên diễn đàn giúp làm ra phần phát sinh.
Nhưng nay em muốn thêm vào dòng cộng và tổng cộng bằng code vba luôn (các dòng tô màu vàng), mong nhận được sự giúp đỡ của mọi người.
Code trong Module 2
Em xin cảm ơn.
 

File đính kèm

Sắp xếp theo thời gian sắp xếp theo bầu chọn
Em cũng đang tìm code này. tiện bác nào chỉ luôn e với :(
 
Upvote 0
Thêm dòng như thế nào bạn?
Thiết nghĩ nếu bạn thêm dòng thì code cũng sẽ tự thêm dòng thôi.
 
Upvote 0
Nếu là mình thì các tổng & cộng tổng nên áp công thức; Không thèm xài VBA;
Mà cũng không cần xài đến Dictionary cho nó hàm lậm, chỉ đưa dữ liệu vô mảng mà duyệt thôi.
Vòng lặp ngoài duyệt theo các (4) hàng của cột B của trang 'THTien'
Vòng lặp trong duyệt theo dữ liệu của mảng ( Arr = .Range("A3:J" & A).Value)
Cái nào thỏa ngày nào thì ghi vô 1 trong 3 tham biến (DuDauKy; TangTrongKy & GiamTrongKy là được
Duyệt xong dòng nào của trang 'THTien' thì ghi các tham biến tương ứng vô 3 cột
(Xóa về 0 các tham biến, để ghi cho dòng dưới liền kề có dữ liệu của trang)

Với hướng này bạn dễ bảo trì hơn nhiều.
 
Upvote 0
SA_DQ đã viết:
Nếu là mình thì các tổng & cộng tổng nên áp công thức; Không thèm xài VBA;
Mà cũng không cần xài đến Dictionary cho nó hàm lậm, chỉ đưa dữ liệu vô mảng mà duyệt thôi.
Vòng lặp ngoài duyệt theo các (4) hàng của cột B của trang 'THTien'
Vòng lặp trong duyệt theo dữ liệu của mảng ( Arr = .Range("A3:J" & A).Value)
Cái nào thỏa ngày nào thì ghi vô 1 trong 3 tham biến (DuDauKy; TangTrongKy & GiamTrongKy là được
Duyệt xong dòng nào của trang 'THTien' thì ghi các tham biến tương ứng vô 3 cột
(Xóa về 0 các tham biến, để ghi cho dòng dưới liền kề có dữ liệu của trang)

Với hướng này bạn dễ bảo trì hơn nhiều.
Nhấp chuột vào đây để mở rộng...
Dạ vì em không rành VBA lắm, thầy có thể làm phần này giúp em không ạ - theo ý của thầy.
 
Upvote 0

File đính kèm

Upvote 0
Ai cũng chê hay sao ý:
PHP: 
Sub TongHopPhatSinh()
Dim Rws As Long, J As Long, DuDK As Double, Tang As Double, Giam As Double, Tmp As Double
Dim Arr(), Cls As Range
Dim CT As Integer

With Sheets("NhapLieu")
    Rws = .[b3].CurrentRegion.Rows.Count
    Arr() = .[b3].Resize(Rws, 8).Value:                             Tmp = Timer()
End With
With Sheets("THTien")
    fDat = .[d7].Value:                                               lDat = .[g7].Value
    For Each Cls In .Range(.[b11], .[B65500].End(xlUp))
        If Cls.Value = "" Then GoTo GPE
        For J = 1 To UBound(Arr())
            If Arr(J, 8) = Cls.Value Then
                If Arr(J, 2) <> Space(0) Then CT = 1 Else CT = -1
                If Arr(J, 1) < fDat Then
                    DuDK = DuDK + CT * Arr(J, 7)
                ElseIf Arr(J, 1) >= fDat And Arr(J, 1) <= lDat Then
                    If CT Then
                        Tang = Tang + Arr(J, 7)
                    Else
                        Giam = Giam + Arr(J, 7)
                    End If
                End If
            End If
        Next J
        .Cells(Cls.Row, "F").Value = DuDK:          DuDK = 0
        .Cells(Cls.Row, "G").Value = Tang:          Tang = 0
        .Cells(Cls.Row, "H").Value = Giam:          Giam = 0
GPE:
    Next Cls
End With
MsgBox Timer() - Tmp
End Sub
 
Lần chỉnh sửa cuối:
Upvote 0
SA_DQ đã viết:
Ai cũng chê hay sao ý:
PHP: 
Sub TongHopPhatSinh()
Dim Rws As Long, J As Long, DuDK As Double, Tang As Double, Giam As Double, Tmp As Double
Dim Arr(), Cls As Range
Dim CT As Integer

With Sheets("NhapLieu")
    Rws = .[b3].CurrentRegion.Rows.Count
    Arr() = .[b3].Resize(Rws, 8).Value:                             Tmp = Timer()
End With
With Sheets("THTien")
    fDat = .[d7].Value:                                                     lDat = .[g7].Value
    For Each Cls In .Range(.[b11], .[B65500].End(xlUp))
        If Cls.Value = "" Then GoTo GPE
        For J = 1 To UBound(Arr())
            If Arr(J, 8) = Cls.Value Then
                If Arr(J, 2) <> Space(0) Then CT = 1 Else CT = -1
                If Arr(J, 1) < fDat Then
                    DuDK = DuDK + CT * Arr(J, 7)
                ElseIf Arr(J, 1) >= fDat And Arr(J, 1) <= lDat Then
                    If CT Then
                        Tang = Tang + Arr(J, 7)
                    Else
                        Giam = Giam + Arr(J, 7)
                    End If
                End If
            End If
        Next J
        .Cells(Cls.Row, "F").Value = DuDK:          DuDK = 0
        .Cells(Cls.Row, "G").Value = Tang:          Tang = 0
        .Cells(Cls.Row, "H").Value = Giam:          Giam = 0
GPE:
    Next Cls
End With
MsgBox Timer() - Tmp
End Sub
Nhấp chuột vào đây để mở rộng...
Dạ em cảm ơn thầy.
 
Upvote 0
SA_DQ đã viết:
Ai cũng chê hay sao ý:
PHP: 
Sub TongHopPhatSinh()
Dim Rws As Long, J As Long, DuDK As Double, Tang As Double, Giam As Double, Tmp As Double
Dim Arr(), Cls As Range
Dim CT As Integer

With Sheets("NhapLieu")
    Rws = .[b3].CurrentRegion.Rows.Count
    Arr() = .[b3].Resize(Rws, 8).Value:                             Tmp = Timer()
End With
With Sheets("THTien")
    fDat = .[d7].Value:                                                     lDat = .[g7].Value
    For Each Cls In .Range(.[b11], .[B65500].End(xlUp))
        If Cls.Value = "" Then GoTo GPE
        For J = 1 To UBound(Arr())
            If Arr(J, 8) = Cls.Value Then
                If Arr(J, 2) <> Space(0) Then CT = 1 Else CT = -1
                If Arr(J, 1) < fDat Then
                    DuDK = DuDK + CT * Arr(J, 7)
                ElseIf Arr(J, 1) >= fDat And Arr(J, 1) <= lDat Then
                    If CT Then
                        Tang = Tang + Arr(J, 7)
                    Else
                        Giam = Giam + Arr(J, 7)
                    End If
                End If
            End If
        Next J
        .Cells(Cls.Row, "F").Value = DuDK:          DuDK = 0
        .Cells(Cls.Row, "G").Value = Tang:          Tang = 0
        .Cells(Cls.Row, "H").Value = Giam:          Giam = 0
GPE:
    Next Cls
End With
MsgBox Timer() - Tmp
End Sub
Nhấp chuột vào đây để mở rộng...
Dạ thầy ơi em test mà nó bị lỗi
216752
 
Upvote 0
Mình nhồm hình không rõ, nhưng đoán là nó báo thời gian đã dùng để chạy macro trên file của bạn đó thôi.
 
Upvote 0
Đó là hiệu thời gian đầu & cuối khi thực hành 1 lần của macro
 
Upvote 0
hoangminh2018 đã viết:
Em có file này trước đây có một anh trên diễn đàn giúp làm ra phần phát sinh.
Nhưng nay em muốn thêm vào dòng cộng và tổng cộng bằng code vba luôn (các dòng tô màu vàng), mong nhận được sự giúp đỡ của mọi người.
Code trong Module 2
Em xin cảm ơn.
Nhấp chuột vào đây để mở rộng...
Chạy code
Mã: 
Sub GPE()
  Dim i As Long, ik As Long, d As Long, sRow As Long
  Dim sArr(), tArr(), Res(), dic As Object, iKey As String
  Dim eDate As Long, fDate As Long, Ngay As Long

  Set dic = CreateObject("Scripting.dictionary")
  With Sheets("NhapLieu")
    i = .Range("B" & Rows.Count).End(xlUp).Row
    If i < 3 Then MsgBox "khong co du lieu": Exit Sub
    sArr = .Range("B3:I" & i).Value
  End With
  With Sheets("THTien")
    fDate = CLng(.Range("D7").Value)
    eDate = CLng(.Range("G7").Value)
    tArr = .Range("B11:E" & .Range("B" & Rows.Count).End(xlUp).Row + 1).Value
    sRow = UBound(tArr)
  End With
  ReDim Res(1 To sRow + 1, 1 To 5)
  For i = 1 To sRow - 1
    iKey = tArr(i, 1)
    If Len(iKey) > 0 Then
      dic.Add iKey, i
      Res(i, 1) = tArr(i, 4): Res(i, 2) = tArr(i, 4): Res(i, 5) = tArr(i, 4)
    End If
  Next i
  For i = 1 To UBound(sArr)
    ik = dic.Item(sArr(i, 8))
    If ik > 0 Then
      If IsDate(sArr(i, 1)) Then
        Ngay = CLng(sArr(i, 1))
        If Len(sArr(i, 2)) > 0 Then d = 1 Else d = -1
        If Ngay < fDate Then
          Res(ik, 2) = Res(ik, 2) + sArr(i, 7) * d
          Res(ik, 5) = Res(ik, 5) + sArr(i, 7) * d
        ElseIf Ngay <= eDate Then
          Res(ik, 5) = Res(ik, 5) + sArr(i, 7) * d
          Res(ik, (7 - d) / 2) = Res(ik, (7 - d) / 2) + sArr(i, 7)
        End If
      End If
    End If
  Next i
  For i = sRow To 1 Step -1
    If Len(tArr(i, 1)) = 0 Then
      ik = i
    Else
      For d = 1 To 5
        If Len(Res(i, d)) > 0 Then
          Res(ik, d) = Res(ik, d) + Res(i, d)
          Res(sRow + 1, d) = Res(sRow + 1, d) + Res(i, d)
        End If
      Next d
    End If
  Next i
  Sheets("THTien").Range("E11").Resize(sRow + 1, 5) = Res
End Sub
 
Upvote 0
HieuCD đã viết:
Chạy code
Mã: 
Sub GPE()
  Dim i As Long, ik As Long, d As Long, sRow As Long
  Dim sArr(), tArr(), Res(), dic As Object, iKey As String
  Dim eDate As Long, fDate As Long, Ngay As Long

  Set dic = CreateObject("Scripting.dictionary")
  With Sheets("NhapLieu")
    i = .Range("B" & Rows.Count).End(xlUp).Row
    If i < 3 Then MsgBox "khong co du lieu": Exit Sub
    sArr = .Range("B3:I" & i).Value
  End With
  With Sheets("THTien")
    fDate = CLng(.Range("D7").Value)
    eDate = CLng(.Range("G7").Value)
    tArr = .Range("B11:E" & .Range("B" & Rows.Count).End(xlUp).Row + 1).Value
    sRow = UBound(tArr)
  End With
  ReDim Res(1 To sRow + 1, 1 To 5)
  For i = 1 To sRow - 1
    iKey = tArr(i, 1)
    If Len(iKey) > 0 Then
      dic.Add iKey, i
      Res(i, 1) = tArr(i, 4): Res(i, 2) = tArr(i, 4): Res(i, 5) = tArr(i, 4)
    End If
  Next i
  For i = 1 To UBound(sArr)
    ik = dic.Item(sArr(i, 8))
    If ik > 0 Then
      If IsDate(sArr(i, 1)) Then
        Ngay = CLng(sArr(i, 1))
        If Len(sArr(i, 2)) > 0 Then d = 1 Else d = -1
        If Ngay < fDate Then
          Res(ik, 2) = Res(ik, 2) + sArr(i, 7) * d
          Res(ik, 5) = Res(ik, 5) + sArr(i, 7) * d
        ElseIf Ngay <= eDate Then
          Res(ik, 5) = Res(ik, 5) + sArr(i, 7) * d
          Res(ik, (7 - d) / 2) = Res(ik, (7 - d) / 2) + sArr(i, 7)
        End If
      End If
    End If
  Next i
  For i = sRow To 1 Step -1
    If Len(tArr(i, 1)) = 0 Then
      ik = i
    Else
      For d = 1 To 5
        If Len(Res(i, d)) > 0 Then
          Res(ik, d) = Res(ik, d) + Res(i, d)
          Res(sRow + 1, d) = Res(sRow + 1, d) + Res(i, d)
        End If
      Next d
    End If
  Next i
  Sheets("THTien").Range("E11").Resize(sRow + 1, 5) = Res
End Sub
Nhấp chuột vào đây để mở rộng...
Dạ em chạy thử rồi, ra kết quả đúng luôn, em xin cảm ơn.
 
Upvote 0
Góp ý thêm với bạn hoangminh2018
Theo mình các ô trong vùng nhập liệu cột I của sheet NhapLieu bạn nên để chế độ DataValidation để kiểm soát việc bổ sung Mã ngân hàng, hoặc bổ sung Mã quỹ tiền mặt
Vì khi sheet NhapLieu có thêm Mã Ngân hàng hoặc mã quỹ tiền mặt mới thì bên Sheet THTien không tự động cập nhập mà User phải có 1 bước Insert thêm dòng, khi đó code mới chạy tổng cho dòng mã mới đó.
Vậy nên Nếu không có 1 DataValidation List để kiểm soát Mã ngân hàng, hoặc Mã quỹ tiền mặt thì có thể sẽ bị sót khi tổng cộng
 
Upvote 0
Nguyễn Hồng Quang đã viết:
Góp ý thêm với bạn hoangminh2018
Theo mình các ô trong vùng nhập liệu cột I của sheet NhapLieu bạn nên để chế độ DataValidation để kiểm soát việc bổ sung Mã ngân hàng, hoặc bổ sung Mã quỹ tiền mặt
Vì khi sheet NhapLieu có thêm Mã Ngân hàng hoặc mã quỹ tiền mặt mới thì bên Sheet THTien không tự động cập nhập mà User phải có 1 bước Insert thêm dòng, khi đó code mới chạy tổng cho dòng mã mới đó.
Vậy nên Nếu không có 1 DataValidation List để kiểm soát Mã ngân hàng, hoặc Mã quỹ tiền mặt thì có thể sẽ bị sót khi tổng cộng
Nhấp chuột vào đây để mở rộng...
Cảm ơn anh đã cho em ý kiến ạ.
 
Upvote 0
hoangminh2018 đã viết:
Cảm ơn anh đã cho em ý kiến ạ.
Nhấp chuột vào đây để mở rộng...
Xem thử cái này nhé (tất cả vẫn là của bạn đấy thôi)
Code Tổng hợp dữ liệu về sheet THTien là của anh HieuCD
Mình chỉ bổ sung thêm datavalidation và 1 chút để kiểm soát danh sách Mã và cập nhập mã sang sheet tổng hợp
 

File đính kèm

Lần chỉnh sửa cuối:
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

X
Làm thế nào để ẩn "Blank" trong Pivot table (3 người xem)
    • Thích
Trả lời
15
Đọc
36K
nguyenngochieu761321
nguyenngochieu761321
ongke0711
  • Question Question
Tải hóa đơn điện tử (https://hoadondientu.gdt.gov.vn/) Excel Vba (4 người xem)
    • Thích
    • Yêu thích
    • Cảm ơn
3 4 5
Trả lời
437
Đọc
57K
trdethuong
T
V
Quản lý xuất nhập vật tư trong kho (1 người xem)
Trả lời
17
Đọc
639
LOGANWover
L
H
Đánh số thự theo lượt
Trả lời
5
Đọc
99
hongminh_0306
H
D
XIN PHẦN MỀM XẾP TKB TIỂU HỌC BẰNG EXCEL
Trả lời
2
Đọc
153
danhpheo
D
phuongnam366377
Học C++ từ số 0 – Bài học đầu tiên
    • Cảm ơn
Trả lời
2
Đọc
154
phuongnam366377
phuongnam366377
A
  • Question Question
Copy 2 form sang file khác, có 1 form Show, 1 form không Show
Trả lời
2
Đọc
113
AnhThu-1976
A
R
Các bác có kinh nghiệm excel cho em xin công thức đánh số thứ tự theo ngày tháng này vợi ạ.
Trả lời
5
Đọc
170
truc.duong87
T
H
Tự động cập nhật dữ liệu từ 2 file word
Trả lời
1
Đọc
121
LOGANWover
L
N
Nhờ giúp Drop down list theo tỉnh xã mới.
Trả lời
7
Đọc
309
ongke0711
ongke0711
E
VBA copy ô trong excel khi đang lọc filter (1 người xem)
Trả lời
8
Đọc
169
eagle12
E
N
Không sử dụng được phím tắt Ctrl + Shift + mũi tên xuống (1 người xem)
Trả lời
1
Đọc
3K
aFdangthacmac
A
L
  • Question Question
Gõ và chọn tên trong ComboBox hiển thị giá trị trong textbox
    • Cười
Trả lời
8
Đọc
414
ongke0711
ongke0711
befaint
[ Python và ứng dụng ] Công cụ trích xuất hàng loạt hóa đơn điện tử XML vào bảng Excel
    • Thích
    • Yêu thích
    • Cảm ơn
Trả lời
56
Đọc
9K
Hoale85
H
Nam168
Không mở được file excel
Trả lời
2
Đọc
105
Nam168
Nam168
phuongnam366377
Sử dụng COM DLL **không cần đăng ký** với Delphi 12 / C++ Builder
    • Thích
Trả lời
0
Đọc
123
phuongnam366377
phuongnam366377
N
Định mức nguyên vật liệu
Trả lời
49
Đọc
5K
ntan50
N
H
  • Question Question
Dò tìm giá trị từ bảng khác theo cột
Trả lời
6
Đọc
327
Chả_biết_gì
C
2
  • Question Question
Hỏi cách in phiếu điều tra PCGD-XMC từ file dữ liệu mẫu xuất ra từ hệ thống PCGD-XMC của Bộ GD
    • Thích
Trả lời
26
Đọc
1K
haitien123
H
ongke0711
Truy cập trang GPE chậm
    • Thích
Trả lời
3
Đọc
241
Hai Lúa Miền Tây
Hai Lúa Miền Tây
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