Nhờ viết 1 đoạn code VBA

Liên hệ QC
M

minhhoai1963

Thành viên mới
Tham gia
27/4/22
Bài viết
3
Được thích
1
Tôi mới tham gia Diễn đàn và muốn nhờ các Anh chị giúp tôi 1 đoạn code VBA đính kèm file sau. Xin trân trọng cảm ơn!
 

File đính kèm

  • LAP BANG TH CHI PHI.xlsx
    19.9 KB · Đọc: 38
Sắp xếp theo thời gian sắp xếp theo bầu chọn
snow25 đã viết:
Đợi xem ai giải bài này.
Nhấp chuột vào đây để mở rộng...
Họ mới vào diễn đàn có lẽ cũng chưa đọc qua nội quy, tôi nghĩ nên nhắc nhở họ.
minhhoai1963 đã viết:
Tôi mới tham gia Diễn đàn và muốn nhờ các Anh chị giúp tôi 1 đoạn code VBA đính kèm file sau. Xin trân trọng cảm ơn!
Nhấp chuột vào đây để mở rộng...
Bạn vào đọc nội quy tại đây (Mục III). Sau đó sửa tiêu đề cho phù hợp:
Đại loại tiêu đề có thể là "Chuyển mã hợp đồng và loại hợp đồng từ bảng danh mục sang bảng tổng hợp".
 
Upvote 0
Pivot Table. Không giống ý chủ 100%. Nhưng đó là cách hiệu nghiệm nhất.

(chịu khó mò cách trình bày một chút sẽ ra gần giống)
 
Upvote 0
Dùng tạm trong khi chờ các cao thủ khác ra tay:
PHP: 
Option Explicit
Sub test()
Dim lr&, i&, j&, k&, c&, sum As Double, grand As Double, t&, arrKQ, rngDM, rngDS, cell As Range
Sheets("DMHD").Activate
lr = Cells(Rows.Count, "B").End(xlUp).Row
rngDS = Sheets("Sheet2").Range("A1:B" & Sheets("Sheet2").Cells(Rows.Count, "A").End(xlUp).Row).Value ' Danh sách loai hop dong, them cot B dien giai ten hop dong
rngDM = Range("B7:G" & lr).Value
ReDim arrKQ(1 To 10000, 1 To 5)
For i = 1 To UBound(rngDS)
    For j = 1 To UBound(rngDM)
        If rngDS(i, 1) = rngDM(j, 3) Then
            c = c + 1' dem so lan xuat hien cua hop dong
            k = k + 1
            If c = 1 Then ' tai dong dau tien cua loai hop dong
                t = k' danh dau dong dau tien
                arrKQ(k, 1) = WorksheetFunction.Roman(i) ' dong tong hop moi loai hop dong cua vung ket qua
                arrKQ(k, 2) = rngDM(j, 3)
                arrKQ(k, 3) = rngDS(i, 2)
                k = k + 1                               ' dong dau tien cua chi tiet
                arrKQ(k, 1) = c
                arrKQ(k, 2) = rngDM(j, 1)
                arrKQ(k, 3) = rngDM(j, 2)
                arrKQ(k, 4) = rngDM(j, 5)
                arrKQ(k, 5) = rngDM(j, 6)
                sum = sum + rngDM(j, 5)' cong don gia tri cua tung loai hop dong
            Else
                'k = k + 1
                arrKQ(k, 1) = c                         ' dong chi tiet
                arrKQ(k, 2) = rngDM(j, 1)
                arrKQ(k, 3) = rngDM(j, 2)
                arrKQ(k, 4) = rngDM(j, 5)
                arrKQ(k, 5) = rngDM(j, 6)
                sum = sum + rngDM(j, 5) ' cong don gia tri cua tung loai hop dong
            End If
        End If
    Next
arrKQ(t, 4) = sum' gan sum cho dong dau tien cua hop dong
grand = grand + sum ' cong don tat ca cac loai hop dong
c = 0:  sum = 0
Next
arrKQ(k + 2, 3) = "TONG CONG"
arrKQ(k + 2, 4) = grand
Range("J6:N100").Delete
Range("J6").Resize(UBound(arrKQ), 5) = arrKQ
For Each cell In Range("J6").Resize(UBound(arrKQ), 1).SpecialCells(xlCellTypeConstants, xlTextValues)
    cell.Resize(1, 5).Font.Bold = True
Next
Range(Cells(k + 7, "L"), Cells(k + 7, "M")).Font.Bold = True
End Sub
 

File đính kèm

  • LAP BANG TH CHI PHI.xlsm
    21.9 KB · Đọc: 30
Lần chỉnh sửa cuối:
Upvote 0
bebo021999 đã viết:
Dùng tạm trong khi chờ các cao thủ khác ra tay:
PHP: 
Option Explicit
Sub test()
Dim lr&, i&, j&, k&, c&, sum As Double, grand As Double, t&, arrKQ, rngDM, rngDS, cell As Range
Sheets("DMHD").Activate
lr = Cells(Rows.Count, "B").End(xlUp).Row
rngDS = Sheets("Sheet2").Range("A1:B" & Sheets("Sheet2").Cells(Rows.Count, "A").End(xlUp).Row).Value ' Danh sách loai hop dong, them cot B dien giai ten hop dong
rngDM = Range("B7:G" & lr).Value
ReDim arrKQ(1 To 10000, 1 To 5)
For i = 1 To UBound(rngDS)
    For j = 1 To UBound(rngDM)
        If rngDS(i, 1) = rngDM(j, 3) Then
            c = c + 1' dem so lan xuat hien cua hop dong
            k = k + 1
            If c = 1 Then ' tai dong dau tien cua loai hop dong
                t = k' danh dau dong dau tien
                arrKQ(k, 1) = WorksheetFunction.Roman(i) ' dong tong hop moi loai hop dong cua vung ket qua
                arrKQ(k, 2) = rngDM(j, 3)
                arrKQ(k, 3) = rngDS(i, 2)
                k = k + 1                               ' dong dau tien cua chi tiet
                arrKQ(k, 1) = c
                arrKQ(k, 2) = rngDM(j, 1)
                arrKQ(k, 3) = rngDM(j, 2)
                arrKQ(k, 4) = rngDM(j, 5)
                arrKQ(k, 5) = rngDM(j, 6)
                sum = sum + rngDM(j, 5)' cong don gia tri cua tung loai hop dong
            Else
                'k = k + 1
                arrKQ(k, 1) = c                         ' dong chi tiet
                arrKQ(k, 2) = rngDM(j, 1)
                arrKQ(k, 3) = rngDM(j, 2)
                arrKQ(k, 4) = rngDM(j, 5)
                arrKQ(k, 5) = rngDM(j, 6)
                sum = sum + rngDM(j, 5) ' cong don gia tri cua tung loai hop dong
            End If
        End If
    Next
arrKQ(t, 4) = sum' gan sum cho dong dau tien cua hop dong
grand = grand + sum ' cong don tat ca cac loai hop dong
c = 0:  sum = 0
Next
arrKQ(k + 2, 3) = "TONG CONG"
arrKQ(k + 2, 4) = grand
Range("J6:N100").Delete
Range("J6").Resize(UBound(arrKQ), 5) = arrKQ
For Each cell In Range("J6").Resize(UBound(arrKQ), 1).SpecialCells(xlCellTypeConstants, xlTextValues)
    cell.Resize(1, 5).Font.Bold = True
Next
Range(Cells(k + 7, "L"), Cells(k + 7, "M")).Font.Bold = True
End Sub
Nhấp chuột vào đây để mở rộng...
Cái này dùng Dictionary có vẻ nhanh hơn anh à.
 
Upvote 0
Bạn bebo chụp ảnh avatar độc thiệt làm tôi cứ tưởng là bạn đang đội mũ cử nhân ltrong lễ tốt nghiệp đại học.
 
Upvote 0
Upvote 0
bebo021999 đã viết:
Lót dép hóng @snow25 giải bài này với dic !!!!!
Nhấp chuột vào đây để mở rộng...
Thử code.
Mã: 
Sub fdfsdfs()
    Dim i As Long, lr As Long, dic As Object, arr, kq, data, T, k As Integer, c As Long, tong As Double, dk As String, a As Long
    Set dic = CreateObject("scripting.dictionary")
    With Sheets("DMHD")
         lr = .Range("B" & Rows.Count).End(xlUp).Row
         arr = .Range("B7:F" & lr).Value
         ReDim kq(1 To UBound(arr) + 100, 1 To 5)
         For i = 1 To UBound(arr)
             dk = arr(i, 3)
             If Not dic.exists(dk) Then
                dic.Add dk, Array(i)
             Else
                T = dic.Item(dk)
                ReDim Preserve T(UBound(T) + 1)
                T(UBound(T)) = i
                dic.Item(dk) = T
             End If
         Next i
         data = dic.keys
         For k = 0 To UBound(data)
             a = a + 1
             c = a
             kq(a, 1) = WorksheetFunction.Roman(k + 1)
             kq(a, 2) = data(k)
             dk = data(k)
             T = dic.Item(dk)
             For i = 0 To UBound(T)
                 a = a + 1
                 kq(a, 1) = i + 1
                 kq(a, 2) = arr(T(i), 1)
                 kq(a, 3) = arr(T(i), 2)
                 kq(a, 4) = arr(T(i), 5)
                 kq(c, 4) = kq(c, 4) + kq(a, 4)
             Next i
             tong = tong + kq(c, 4)
         Next k
         a = a + 2
         kq(a, 3) = "Tong cong"
         kq(a, 4) = tong
         lr = .Range("J" & Rows.Count).End(xlUp).Row
         If lr > 6 Then .Range("J6:N" & lr).ClearContents
         .Range("J6:N6").Resize(a).Value = kq
  End With
  Set dic = Nothing
End Sub
 
Upvote 0
minhhoai1963 đã viết:
Tôi mới tham gia Diễn đàn và muốn nhờ các Anh chị giúp tôi 1 đoạn code VBA đính kèm file sau. Xin trân trọng cảm ơn!
Nhấp chuột vào đây để mở rộng...
Dạng nầy dữ liệu không nhiều tốc độ code rất nhanh
Mã: 
Sub XYZ()
  Dim sh As Worksheet, sArr(), res(), aCP
  Dim sRow&, i&, r&, stt&, j&, k&, c&, tong#
 
  aCP = Array("", "HDVATTU", "HDMTC", "HDNC", "HDTP")
  Set sh = Sheets("DMHD")
  sArr = sh.Range("B7:G" & sh.Range("B" & Rows.Count).End(xlUp).Row).Value
  sRow = UBound(sArr)
  ReDim res(1 To sRow + 6, 1 To 5)
  For c = 1 To UBound(aCP)
    k = k + 1:    r = k:    stt = 0
    res(r, 1) = WorksheetFunction.Roman(c)
    res(r, 2) = aCP(c)
    For i = 1 To sRow
      If sArr(i, 3) = aCP(c) Then
        k = k + 1
        stt = stt + 1
        res(k, 1) = stt
        res(k, 2) = sArr(i, 1)
        res(k, 3) = sArr(i, 2)
        res(k, 4) = sArr(i, 5)
        res(k, 5) = sArr(i, 6)
        res(r, 4) = res(r, 4) + sArr(i, 5)
        tong = tong + sArr(i, 5)
      End If
    Next i
  Next c
  res(k + 2, 3) = "TONG CONG"
  res(k + 2, 4) = tong
  sh.Range("J6:N1000").Clear
  sh.Range("J6").Resize(k + 2, 5) = res
End Sub
 
Upvote 0
bebo021999 đã viết:
Dùng tạm trong khi chờ các cao thủ khác ra tay:
PHP: 
Option Explicit
Sub test()
Dim lr&, i&, j&, k&, c&, sum As Double, grand As Double, t&, arrKQ, rngDM, rngDS, cell As Range
Sheets("DMHD").Activate
lr = Cells(Rows.Count, "B").End(xlUp).Row
rngDS = Sheets("Sheet2").Range("A1:B" & Sheets("Sheet2").Cells(Rows.Count, "A").End(xlUp).Row).Value ' Danh sách loai hop dong, them cot B dien giai ten hop dong
rngDM = Range("B7:G" & lr).Value
ReDim arrKQ(1 To 10000, 1 To 5)
For i = 1 To UBound(rngDS)
    For j = 1 To UBound(rngDM)
        If rngDS(i, 1) = rngDM(j, 3) Then
            c = c + 1' dem so lan xuat hien cua hop dong
            k = k + 1
            If c = 1 Then ' tai dong dau tien cua loai hop dong
                t = k' danh dau dong dau tien
                arrKQ(k, 1) = WorksheetFunction.Roman(i) ' dong tong hop moi loai hop dong cua vung ket qua
                arrKQ(k, 2) = rngDM(j, 3)
                arrKQ(k, 3) = rngDS(i, 2)
                k = k + 1                               ' dong dau tien cua chi tiet
                arrKQ(k, 1) = c
                arrKQ(k, 2) = rngDM(j, 1)
                arrKQ(k, 3) = rngDM(j, 2)
                arrKQ(k, 4) = rngDM(j, 5)
                arrKQ(k, 5) = rngDM(j, 6)
                sum = sum + rngDM(j, 5)' cong don gia tri cua tung loai hop dong
            Else
                'k = k + 1
                arrKQ(k, 1) = c                         ' dong chi tiet
                arrKQ(k, 2) = rngDM(j, 1)
                arrKQ(k, 3) = rngDM(j, 2)
                arrKQ(k, 4) = rngDM(j, 5)
                arrKQ(k, 5) = rngDM(j, 6)
                sum = sum + rngDM(j, 5) ' cong don gia tri cua tung loai hop dong
            End If
        End If
    Next
arrKQ(t, 4) = sum' gan sum cho dong dau tien cua hop dong
grand = grand + sum ' cong don tat ca cac loai hop dong
c = 0:  sum = 0
Next
arrKQ(k + 2, 3) = "TONG CONG"
arrKQ(k + 2, 4) = grand
Range("J6:N100").Delete
Range("J6").Resize(UBound(arrKQ), 5) = arrKQ
For Each cell In Range("J6").Resize(UBound(arrKQ), 1).SpecialCells(xlCellTypeConstants, xlTextValues)
    cell.Resize(1, 5).Font.Bold = True
Next
Range(Cells(k + 7, "L"), Cells(k + 7, "M")).Font.Bold = True
End Sub
Nhấp chuột vào đây để mở rộng...
Chào bác,
Bác cho em hỏi, nếu trong bảng danh mục hợp đồng có dòng trống nhưng mình không muốn lấy dòng trống, chỉ lấy những dòng có dữ liệu thì sửa như thế nào bác?
Edited: Em đã mò được rồi nha bác.
 
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.
Web KT

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

S
Lý do công thức bị mờ tại ô Function
    • Cười
Trả lời
2
Đọc
37
sakurasumo
S
thlpro
Truy Vấn Công thức từ Sheet này Qua Sheet Khác
Trả lời
6
Đọc
121
Hoàng Tuấn 868
H
GPE-Trợ Lý
Đăng ký tham dự hội thảo tại Hà Nội: Power Query - Công cụ quản lý dữ liệu
    • Thích
    • Cảm ơn
    • Yêu thích
Trả lời
5
Đọc
619
GPE-Trợ Lý
GPE-Trợ Lý
N
  • Question
Làm ơn viết giùm mình macro làm tròn giá trị ạ
    • Cười
Trả lời
14
Đọc
104
ptm0412
ptm0412
ongke0711
  • Question
Tải hóa đơn điện tử (https://hoadondientu.gdt.gov.vn/) Excel Vba
    • Thích
    • Yêu thích
8 9 10
Trả lời
191
Đọc
10K
ongke0711
ongke0711
CNKyNguyen
Giảm dung lượng của file excel
    • Cảm ơn
    • Cười
    • Thích
Trả lời
2
Đọc
228
CNKyNguyen
CNKyNguyen
hunganh.nguyen
Xin giúp code tách dòng tổng thành những dòng chi tiết với giá trị là 1
Trả lời
9
Đọc
404
vostro 1500
vostro 1500
T
Xin trợ giúp code về dò tìm dữ liệu
Trả lời
0
Đọc
61
THU UYEN317
T
P
Sự cố về hàm SUMIF
Trả lời
8
Đọc
230
yeudoi
yeudoi
OverAC
Thông báo nội dung xấu và bài viết vi phạm nội quy.
19 20 21
Trả lời
416
Đọc
41K
vanle33
vanle33
S
Chuyển định dạng thời gian từ sa/ch sang AM/PM
Trả lời
2
Đọc
69
Silklynk
S
B
Sắp xếp lịch trực
5 6 7
Trả lời
130
Đọc
86K
TTVAN28
TTVAN28
N
Giúp em hàm Aggregate không chạy được trên Google sheet ah
Trả lời
4
Đọc
141
nguyenthieny
N
N
  • Question
VBA - copy các sheets unhide và dạng giá trị theo vùng xác định
Trả lời
2
Đọc
87
bebo021999
B
hoaithanh9480
Nhờ giúp đỡ về kiểm phiếu bầu
Trả lời
4
Đọc
103
hoaithanh9480
hoaithanh9480
B
Nhờ anh/chị giúp em tìm hàm cho công thức tính lương
Trả lời
2
Đọc
136
hoangtuaotrang_hp_vn
H
SA_DQ
Phẩu thuật Nụ cười lần 3 tại Huế.
    • Thích
    • Yêu thích
Trả lời
1
Đọc
99
HUONGHCKT
H
K
  • Question
Sử dụng Power Query để xử lý nhật ký chung nhiều nợ nhiều có
    • Cười
Trả lời
14
Đọc
294
viethung78
V
N
cộng các dữ liệu không trùng nhau
Trả lời
13
Đọc
240
DeTong
D
T
Lỗi import dữ liệu
Trả lời
1
Đọc
58
ongke0711
ongke0711
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

Back
Top Bottom