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: 37
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

T
V/v code xử lý dữ liệu bị chậm
Trả lời
1
Đọc
2
BuiQuangThuan
B
S
  • Question
Không lấy đủ dữ liệu bằng kết nối ADO
Trả lời
9
Đọc
196
ongke0711
ongke0711
S
Nhờ giúp đỡ code in toàn bộ danh sách có điều kiện
Trả lời
9
Đọc
185
S.Ha
S
Bich2B
lỗi định dạng ngày không đọc được công thức excel
Trả lời
8
Đọc
147
Bich2B
Bich2B
M
Bảng Pivot ko tự update theo dữ liệu và còn cộng thiếu số liệu.
Trả lời
4
Đọc
29
Hoàng Trọng Nghĩa
Hoàng Trọng Nghĩa
Xem thêm…

Facebook

Giaiphapexcel.com

Group

DIỄN ĐÀN GIẢI PHÁP EXCEL Group 1
DIỄN ĐÀN GIẢI PHÁP EXCEL Group 2

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