Nhờ tính tổng cho từng sản phẩm do từng công ty làm được bằng VBA

LinDan · 13/2/12

Bài này thường ngày tôi làm bằng Pivot table, nay tôi muốn học thêm VBA nhờ các bác làm giúp.

Xin cảm ơn rất nhiều

ndu96081631 · 13/2/12

LinDan đã viết:
Bài này thường ngày tôi làm bằng Pivot table, nay tôi muốn học thêm VBA nhờ các bác làm giúp.
Xin cảm ơn rất nhiều

Dạng bài này có trên GPE lâu rồi
Tặng bạn file này để tham khảo nhé

LinDan · 14/2/12

Bác Ndu chuyển giúp file đính kèm trên sang xls giúp tôi với, máy của tôi chỉ có Office 2003 nên không chạy được nó.

Tôi theo dõi nhiều bài viết từ trên diễn đàn thấy Dictionary của bác Ndu96081631 rất hay, tôi muốn làm bằng cái này vì như bác nói Dictionary nó giải quyết được cả những bài toán bao hàm cả yếu tố tồn tại hay là không tồn tại, nên tôi rất muốn xem Dic sẽ giải quyết bài này như thế nào? Nếu được phiền các bác làm hộ cho theo phương pháp ấy nhé.

Quang_Hải · 14/2/12

Đã chuyển sang 2003 cho bạn rồi đấy

LinDan · 14/2/12

Chà chà file này nặng quá, máy của tôi sau khi mở chọn hàm max để tính, không hiểu sao 3 phút rồi mà chưa xong.

ThuNghi · 14/2/12

LinDan đã viết:
Chà chà file này nặng quá, máy của tôi sau khi mở chọn hàm max để tính, không hiểu sao 3 phút rồi mà chưa xong.

Xem file này, tôi vận dụng code của NDU.

ndu96081631 · 14/2/12

LinDan đã viết:
Chà chà file này nặng quá, máy của tôi sau khi mở chọn hàm max để tính, không hiểu sao 3 phút rồi mà chưa xong.

Bạn thử file mới này xem thế nào nhé
Code đã được cải tiến thêm rất nhiều. Máy tôi cho ra kết quả trong vòng 0.7 giây với dữ liệu 65000 dòng

ThuNghi · 14/2/12

ndu96081631 đã viết:
Bạn thử file mới này xem thế nào nhé
Code đã được cải tiến thêm rất nhiều. Máy tôi cho ra kết quả trong vòng 0.7 giây với dữ liệu 65000 dòng

Qua bài transferData_5 của NDU mới thấy lợi hại của việc khai báo số dòng và cột của mảng. Khai dư quá thì chậm hơn khai vừa đủ và nếu cần thì dùng redim.
Thử dùng thêm 1 for để lấy dic.count mà khai báo nhưng mà chậm hơn là redim với dữ liệu lớn.
Cám ơn NDU.

Quang_Hải · 14/2/12

Nhìn thấy code của các cao thủ mà mình thấy thẹn quá, nhưng làm rồi nên cũng gởi lên góp vui. Code mình viết là chỉ để cho anh em mới học VBA, nên chạy chậm tí

Private Sub CommandButton1_Click()
Dim ketqua, ketqua1, r, r1, c, n
Application.ScreenUpdating = False
For r1 = 2 To 5
For c = 6 To 8
n = [a65000].End(3).Row
For r = 2 To n
If Cells(r, 1) & Cells(r, 2) = Cells(r1, 5) & Cells(1, c) Then
ketqua = Cells(r, 3)
ketqua1 = ketqua1 + ketqua
End If
Next
Cells(r1, c) = ketqua1
ketqua1 = 0
Next
Next
Application.ScreenUpdating = True
End Sub

LinDan · 14/2/12

Xin hỏi 2 Sub nên để ở hai Module hay là để trên cùng một Module

Tôi thấy trên diễn đàn, có bài toán bao gồm 2 Sub trở lên, thường có 2 phương án:

- Từng Sub trên một Module (Module1, Module 2...)
- Gộp chung các Sub vào trong 1 Module

Xin hỏi trong 2 cách trên thì cách nào thuận tiện hơn.

TrungChinhs · 14/2/12

LinDan đã viết:
Tôi thấy trên diễn đàn, có bài toán bao gồm 2 Sub trở lên, thường có 2 phương án:

- Từng Sub trên một Module (Module1, Module 2...)
- Gộp chung các Sub vào trong 1 Module

Xin hỏi trong 2 cách trên thì cách nào thuận tiện hơn.

Bất luận Sub dài hay ngắn Tôi thường viết mỗi Sub một Module và sửa tên Module thành tên riêng (tương tự như đổi tên Sheet) để cho dễ tìm. Ví dụ Module1 chứa Sub TongCong() thì đổi Module1 =TongCong

LinDan · 14/2/12

Bài toán này trông thế mà phức tạp gớm

PHP:

Sub TaoBC()
Dim endR&, i&, iR&, iC&, nR&, nC&
Dim Arr, ArrKQ
Dim Tmp01$, Tmp02$
Dim Dic01 As Object, Dic02 As Object
Set Dic01 = CreateObject("Scripting.Dictionary")
Set Dic02 = CreateObject("Scripting.Dictionary")
With Sheets("Data")
  .AutoFilterMode = False
  endR = .Cells(65000, 1).End(3).Row
  Arr = .Range(.Cells(2, 1), .Cells(endR, 3)).Value
End With
ReDim ArrKQ(1 To UBound(Arr), 1 To 200)
iR = 1: iC = 1
For i = 1 To UBound(Arr)
  If Len(CStr(Arr(i, 1))) > 0 Then
    If Len(CStr(Arr(i, 2))) > 0 Then
      Tmp01 = CStr(Arr(i, 1))
      If Not Dic01.Exists(Tmp01) Then
        iR = iR + 1
        Dic01.Add Tmp01, iR
        ArrKQ(iR, 1) = Tmp01
      End If
      Tmp02 = Arr(i, 2)
      If Not Dic02.Exists(Tmp02) Then
        iC = iC + 1
        Dic02.Add Tmp02, iC
        ArrKQ(1, iC) = Tmp02
      End If
      nR = Dic01.Item(Tmp01)
      nC = Dic02.Item(Tmp02)
      ArrKQ(nR, nC) = ArrKQ(nR, nC) + Arr(i, 3)
    End If
  End If
Next i
If iR And iC Then
  With Sheets("sheet2")
    .Cells.ClearContents
    .[A1].Resize(iR, iC) = ArrKQ
  End With
End If
Erase Arr, ArrKQ
Set Dic01 = Nothing: Set Dic02 = Nothing
End Sub

Những dòng khai báo trên thì không vấn đề gì, nhưng đến công thức mấu chốt nhất của bài thì phức tạp đây (hình dung mãi nhưng chưa hiểu lắm)
ArrKQ(nR, nC) = ArrKQ(nR, nC) + Arr(i, 3)

Nhờ các pác giải thích dùm công thức trên, cho tôi hình dung cụ thể khi sau khi i chạy đến 12 (tức chạy đến Ô A13) thì ArrKQ(nR,nC)=Arr(2,2) chăng ?
(nR và iR hình như là một tức nR=ỉR? nhưng hình như không phải)

ndu96081631 · 14/2/12

LinDan đã viết:
Tôi thấy trên diễn đàn, có bài toán bao gồm 2 Sub trở lên, thường có 2 phương án:

- Từng Sub trên một Module (Module1, Module 2...)
- Gộp chung các Sub vào trong 1 Module

Xin hỏi trong 2 cách trên thì cách nào thuận tiện hơn.

Bạn muốn đặt sao tùy thích. Riêng tôi, nếu chỉ có 2 Sub thì chẳng việc gì chia ra 2 module
Còn nếu có nhiều sub, tôi sẽ cho những sub có chung 1 công dụng vào 1 module... Giống như file điều khiển đồng hồ này:
http://www.giaiphapexcel.com/forum/showthread.php?39729-Tạo-quả-lắc-(đồng-hồ)-theo-chu-kỳ-1-giây&p=281099#post281099
tôi cho các sub điều khiển kim đồng hồ vào 1 sub, các sub điều khiển âm thanh vào 1 sub với mục đích phân loại cho dể tìm... Thế thôi!
------------------------------

LinDan đã viết:
Bài toán này trông thế mà phức tạp gớm

Những dòng khai báo trên thì không vấn đề gì, nhưng đến công thức mấu chốt nhất của bài thì phức tạp đây (hình dung mãi nhưng chưa hiểu lắm)
ArrKQ(nR, nC) = ArrKQ(nR, nC) + Arr(i, 3)

Nhờ các pác giải thích dùm công thức trên, cho tôi hình dung cụ thể khi sau khi i chạy đến 12 (tức chạy đến Ô A13) thì ArrKQ(nR,nC)=Arr(2,2) chăng ?
(nR và iR hình như là một tức nR=ỉR? nhưng hình như không phải)

- Vòng lập duyệt từ trên xuống
- "Quăng" từng em của cột A vào Dic1 và từng phần tử của cột B vào Dic2 (nếu nó chưa tồn tại)
- Ngay tại thời điểm này, xác định vị trí nR và nC chính là vị trí dòng, cột của mảng ArrKQ
- ArrKQ(nR, nC) chính là vị trí mà ta cần cộng dồn vào bằng cách lấy chính nó cộng với dòng tương ứng (dòng i) của cột C

trungvdb · 14/2/12

Nhờ các pác giải thích dùm công thức trên, cho tôi hình dung cụ thể khi sau khi i chạy đến 12 (tức chạy đến Ô A13) thì ArrKQ(nR,nC)=Arr(2,2) chăng ? (nR và iR hình như là một tức nR=ỉR? nhưng hình như không phải)

* nR và iR khác nhau chứ bạn:

- nR là số thứ tự (Item) của các phần tử trong Dic, các phần tử trong Dic.01 bài này chính là các Công ty mà; bạn cứ tưởng tượng Item nó như là số thứ tự để quản lý công văn đến hàng ngày vậy, mỗi công văn được theo dõi bằng 1 mã số duy nhất để tiện tra cứu. Ở bài này số công văn tìm thấy đầu tiên (Công ty A) được đánh số bắt đầu là 2, khi i = 12 gặp lại Công ty A nghĩa là Công ty A đã được đánh số theo dõi là 2 rồi thì không đánh lại nữa (tức nR=2).

- Mặt khác: iR khi sau khi i chạy đến 12 thì iR=4 (do nó chạy qua 3 ô khác nhau, mỗi khi kiểm tra một ô nào đó kết quả không nằm trong Dic thì iR nó tự động tăng thêm một đơn vị, cộng với 1 đơn vị được khuyễn mãi trước khi chạy, như vậy tổng cộng iR=1+3=4).

Trong số các bài trước được sư phụ Ndu chỉ, bài này có lẽ là bài tiêu biểu nó lên vai trò quan trọng của thành phần Item trong Dic.Add Tmp, Item

LinDan · 15/2/12

Bác Thu Nghi giải thích giúp
With Sheets("Data")
.AutoFilterMode = False
có tác dụng gì thế? Tại sao cần dùng đến nó hả bác

ndu96081631 · 15/2/12

LinDan đã viết:
Bác Thu Nghi giải thích giúp
With Sheets("Data")
.AutoFilterMode = False
có tác dụng gì thế? Tại sao cần dùng đến nó hả bác

Vì code của bác ấy có dùng thuộc tính End(xlUP), mục đích xác định dòng cuối cùng có dữ liệu... Và cái thằng End(xlUP) này sẽ bị sai khi sheet đang có AutoFilter
Chính vì lẽ đó, bác ấy hũy chế độ AutoFilter trước khi thực thi tính toán
Giải thích thêm: Range("A60000").End(xlUp) là tương đương với động tác đặt con trỏ chuột vào cell A60000 rồi bấm tổ hợp phím Ctrl + mũi tên lên

LinDan · 15/2/12

Xin thày Ndu giải thích hộ đoạn If Len(CStr(Arr(i, 1))) > 0 Then tại sao không dùng là If Arr(i, 1) <> "" Then vừa đơn giản, máy đỡ phải chuyển đổi >> nhanh hơn.

kyo · 15/2/12

LinDan đã viết:
Xin thày Ndu giải thích hộ đoạn If Len(CStr(Arr(i, 1))) > 0 Then tại sao không dùng là If Arr(i, 1) <> "" Then vừa đơn giản, máy đỡ phải chuyển đổi >> nhanh hơn.

Theo kinh nghiệm tối ưu hóa code thì việc so sánh số lượng kí tự trong chuỗi sẽ nhanh hơn là so sánh trực tiếp chuỗi đó, tức là nếu bạn so sánh giữa Len(a)=0 và a="" thì Len(a)=0 sẽ nhanh hơn.

LinDan · 15/2/12

Tại sao Code của tôi chạy ra kết quả sai nhỉ

Do chưa có kinh nghiệm, sau khi viết Code khi chạy vẫn ra kết quả nhưng tổng hợp không đúng, phiền mọi người xem hộ tôi, chỉ tôi nhầm ở đâu.

PHP:

Sub Tonghop()
Dim DL(), eR As Long, i As Long, j As Long, Tmp1, Tmp2, Dong, Cot

With Sheets("Sheet1")
eR = .[C65000].End(xlUp).Row
DL = .Range("A2:C" & eR).Value
ReDim KQ(1 To UBound(DL, 1) + 1, 1 To UBound(DL, 1) + 1)
Set Dic1 = CreateObject("Scripting.Dictionary")
Set Dic2 = CreateObject("Scripting.Dictionary")
n = 1
m = 1
For i = 1 To UBound(DL, 1)
    If DL(i, 1) <> "" Then
      Tmp1 = DL(i, 1)
        If Not Dic1.Exists(Tmp1) Then
          n = n + 1
          Dic1.Add Tmp1, n
          Dong = Dic1.Item(Tmp1)
          KQ(n, 1) = Tmp1
    If DL(i, 2) <> "" Then
      Tmp2 = DL(i, 2)
        If Not Dic2.Exists(Tmp2) Then
          m = m + 1
          Dic2.Add Tmp2, m
          Cot = Dic2.Item(Tmp2)
          KQ(1, m) = Tmp2
KQ(Dong, Cot) = KQ(Dong, Cot) + DL(i, 3)
End If
End If
End If
End If
Next
End With

With Sheets("Sheet2")
.Cells.ClearContents
.[A1].Resize(Dong, Cot).Value = KQ
End With

End Sub

ndu96081631 · 15/2/12

LinDan đã viết:

Do chưa có kinh nghiệm, sau khi viết Code khi chạy vẫn ra kết quả nhưng tổng hợp không đúng, phiền mọi người xem hộ tôi, chỉ tôi nhầm ở đâu.

PHP:

Sub Tonghop()
Dim DL(), eR As Long, i As Long, j As Long, Tmp1, Tmp2, Dong, Cot

With Sheets("Sheet1")
eR = .[C65000].End(xlUp).Row
DL = .Range("A2:C" & eR).Value
ReDim KQ(1 To UBound(DL, 1) + 1, 1 To UBound(DL, 1) + 1)
Set Dic1 = CreateObject("Scripting.Dictionary")
Set Dic2 = CreateObject("Scripting.Dictionary")
n = 1
m = 1
For i = 1 To UBound(DL, 1)
    If DL(i, 1) <> "" Then
      Tmp1 = DL(i, 1)
        If Not Dic1.Exists(Tmp1) Then
          n = n + 1
          Dic1.Add Tmp1, n
          Dong = Dic1.Item(Tmp1)
          KQ(n, 1) = Tmp1
    If DL(i, 2) <> "" Then
      Tmp2 = DL(i, 2)
        If Not Dic2.Exists(Tmp2) Then
          m = m + 1
          Dic2.Add Tmp2, m
          Cot = Dic2.Item(Tmp2)
          KQ(1, m) = Tmp2
KQ(Dong, Cot) = KQ(Dong, Cot) + DL(i, 3)
End If
End If
End If
End If
Next
End With

With Sheets("Sheet2")
.Cells.ClearContents
.[A1].Resize(Dong, Cot).Value = KQ
End With

End Sub

Sai quá trời luôn!
Bạn đặt sai vị trí nhiều quá.... Hãy so sánh với cái tôi sửa lại nhé:

PHP:

Sub Tonghop()
  Dim DL, eR As Long, i As Long, n As Long, m As Long, Tmp1, Tmp2, Dong, Cot
  Dim Dic1 As Object, Dic2 As Object, KQ()
  With Sheets("Sheet1")
    DL = .Range(.[A2], .[C65000].End(xlUp)).Value
  End With
  ReDim KQ(1 To UBound(DL, 1), 1 To UBound(DL, 1))
  Set Dic1 = CreateObject("Scripting.Dictionary")
  Set Dic2 = CreateObject("Scripting.Dictionary")
  n = 1
  m = 1
  For i = 1 To UBound(DL, 1)
    If DL(i, 1) <> "" And DL(i, 2) <> "" Then
      Tmp1 = DL(i, 1)
      If Not Dic1.Exists(Tmp1) Then
        n = n + 1
        Dic1.Add Tmp1, n
        
        KQ(n, 1) = Tmp1
      End If
      Tmp2 = DL(i, 2)
      If Not Dic2.Exists(Tmp2) Then
        m = m + 1
        Dic2.Add Tmp2, m
        KQ(1, m) = Tmp2
      End If
      Dong = Dic1.Item(Tmp1)
      Cot = Dic2.Item(Tmp2)
      KQ(Dong, Cot) = KQ(Dong, Cot) + DL(i, 3)
    End If
  Next
  With Sheets("Sheet2")
    .Cells.ClearContents
    .[A1].Resize(Dong, Cot).Value = KQ
  End With
End Sub

Nhờ tính tổng cho từng sản phẩm do từng công ty làm được bằng VBA

Thành viên tiêu biểu

File đính kèm

Huyền thoại GPE

File đính kèm

Thành viên tiêu biểu

Thành viên gạo cội

File đính kèm

Thành viên tiêu biểu

Hãy cho rồi sẽ nhận!

File đính kèm

Huyền thoại GPE

File đính kèm

Hãy cho rồi sẽ nhận!

Thành viên gạo cội

File đính kèm

Thành viên tiêu biểu

Thành viên tích cực

Thành viên tiêu biểu

Huyền thoại GPE

Thành viên thường trực

Thành viên tiêu biểu

Huyền thoại GPE

Thành viên tiêu biểu

Nguyễn Khắc Duy

Thành viên tiêu biểu

Huyền thoại GPE

Đếm ngược thời gian