Lọc trùng và tính tổng cộng bằng Dictionary (1 người xem)

bongmaihung · 1/4/15

Mã:

Sub TK_THANG()
Dim Sarr, Darr(1 To 65536, 1 To 5), i As Long, k As Long, j As Long, Tungay, Denngay, TMP
Dim Dic As Object, Ws As Worksheet
Set Dic = CreateObject("Scripting.Dictionary")
With Sheets("TK_THANG")
    Tungay = .[D2]
    Denngay = .[D3]
End With
For Each Ws In Worksheets
    
    If Ws.Name = "V-ban" Or Ws.Name = "KDT-ban" Then
        Sarr = Ws.Range("A3", Ws.[A65000].End(3)).Resize(, 4).Value
            
            For i = 1 To UBound(Sarr, 1)
                TMP = Sarr(i, 2)
                If Sarr(i, 1) >= Tungay And Sarr(i, 1) <= Denngay Then
                    If Not Dic.exists(TMP) Then
                        k = k + 1
                        Dic.Add TMP, k
                        Darr(k, 1) = Sarr(i, 2)
                        Darr(k, 2) = Sarr(i, 3)
                        If Ws.Name = "V-ban" Then
                            Darr(k, 3) = Sarr(i, 4)
                        Else
                            Darr(k, 4) = Sarr(i, 4)
                        End If
                    Else
                        If Ws.Name = "V-ban" Then
                            Darr(Dic.Item(TMP), 3) = Darr(Dic.Item(TMP), 3) + Sarr(i, 4)
                        Else
                            Darr(Dic.Item(TMP), 4) = Darr(Dic.Item(TMP), 4) + Sarr(i, 4)
                        End If
                            Darr(Dic.Item(TMP), 5) = Darr(Dic.Item(TMP), 4) + Darr(Dic.Item(TMP), 3)
                            
                        End If
                    End If
               
            Next i
        End If
Next Ws
With Sheets("TK_THANG")
If k Then
    .[A6:E65000].ClearContents
    .[A6].Resize(k, 5).Value = Darr
End If
End With
Set Dic = Nothing
End Sub

Trong file em cần lọc trùng và tính tổng cộng, nhưng với mã và sheet1 có mà sheet 2 ko có và ngược lại thì tổng cộng cuối cùng chưa đúng
Chi tiết em gửi theo file , nhờ anh chị giúp đỡ

giangleloi · 1/4/15

bongmaihung đã viết:

Mã:

Sub TK_THANG()
Trong file em cần lọc trùng và tính tổng cộng, nhưng với mã và sheet1 có mà sheet 2 ko có và ngược lại thì tổng cộng cuối cùng chưa đúng
Chi tiết em gửi theo file , nhờ anh chị giúp đỡ[/QUOTE]
Thử sửa như thế này. Thật ra code này rút gọn vẫn còn được.
[Code]
Sub TK_THANG()Dim Sarr, Darr(1 To 65536, 1 To 5), i As Long, k As Long, j As Long, Tungay, Denngay, TMP
Dim Dic As Object, Ws As Worksheet
Set Dic = CreateObject("Scripting.Dictionary")
   With Sheets("TK_THANG")
      Tungay = .[D2]
      Denngay = .[D3]
   End With
For Each Ws In Worksheets
    
   If Ws.Name <> "TK_THANG" Then
        Sarr = Ws.Range("A3", Ws.[A65000].End(3)).Resize(, 4).Value2
           For i = 1 To UBound(Sarr, 1)
              TMP = Sarr(i, 2)
                If Sarr(i, 1) >= Tungay And Sarr(i, 1) <= Denngay Then
                   If Not Dic.exists(TMP) Then
                     k = k + 1
                     Dic.Add TMP, k
                     Darr(k, 1) = Sarr(i, 2)
                     Darr(k, 2) = Sarr(i, 3)
                  If Ws.Name = "V-ban" Then
                     Darr(k, 3) = Sarr(i, 4)
                     Else
                     Darr(k, 4) = Sarr(i, 4)
                  End If
                  Else
                     If Ws.Name = "V-ban" Then
                        Darr(Dic.Item(TMP), 3) = Darr(Dic.Item(TMP), 3) + Sarr(i, 4)
                     Else
                        Darr(Dic.Item(TMP), 4) = Darr(Dic.Item(TMP), 4) + Sarr(i, 4)
                    End If
              End If
          End If
                      Darr(Dic.Item(TMP), 5) = Darr(Dic.Item(TMP), 4) + Darr(Dic.Item(TMP), 3)
       Next i
    End If
Next Ws
With Sheets("TK_THANG")
     If k Then
       .[A6:E65000].ClearContents
       .[A6].Resize(k, 5).Value = Darr
      End If
End With
Set Dic = Nothing
End Sub

bongmaihung · 1/4/15

giangleloi đã viết:

Thử sửa như thế này. Thật ra code này rút gọn vẫn còn được.

Mã:

Sub TK_THANG()Dim Sarr, Darr(1 To 65536, 1 To 5), i As Long, k As Long, j As Long, Tungay, Denngay, TMP
Dim Dic As Object, Ws As Worksheet
Set Dic = CreateObject("Scripting.Dictionary")
   With Sheets("TK_THANG")
      Tungay = .[D2]
      Denngay = .[D3]
   End With
For Each Ws In Worksheets
    
   If Ws.Name <> "TK_THANG" Then
        Sarr = Ws.Range("A3", Ws.[A65000].End(3)).Resize(, 4).Value2
           For i = 1 To UBound(Sarr, 1)
              TMP = Sarr(i, 2)
                If Sarr(i, 1) >= Tungay And Sarr(i, 1) <= Denngay Then
                   If Not Dic.exists(TMP) Then
                     k = k + 1
                     Dic.Add TMP, k
                     Darr(k, 1) = Sarr(i, 2)
                     Darr(k, 2) = Sarr(i, 3)
                  If Ws.Name = "V-ban" Then
                     Darr(k, 3) = Sarr(i, 4)
                     Else
                     Darr(k, 4) = Sarr(i, 4)
                  End If
                  Else
                     If Ws.Name = "V-ban" Then
                        Darr(Dic.Item(TMP), 3) = Darr(Dic.Item(TMP), 3) + Sarr(i, 4)
                     Else
                        Darr(Dic.Item(TMP), 4) = Darr(Dic.Item(TMP), 4) + Sarr(i, 4)
                    End If
              End If
          End If
                      Darr(Dic.Item(TMP), 5) = Darr(Dic.Item(TMP), 4) + Darr(Dic.Item(TMP), 3)
       Next i
    End If
Next Ws
With Sheets("TK_THANG")
     If k Then
       .[A6:E65000].ClearContents
       .[A6].Resize(k, 5).Value = Darr
      End If
End With
Set Dic = Nothing
End Sub

Ok, Được rồi, cảm ơn bạn nhiều

bongmaihung · 1/4/15

File giả định thì ko sao, vào file thật đoạn này báo ngoài vùng
Darr(Dic.Item(TMP), 5) = Darr(Dic.Item(TMP), 4) + Darr(Dic.Item(TMP), 3)
Em gửi lại file đính kèm thật, nhờ anh chị xem lại giúp
Em cảm ơn

Quang_Hải · 1/4/15

bongmaihung đã viết:
File giả định thì ko sao, vào file thật đoạn này báo ngoài vùng
Darr(Dic.Item(TMP), 5) = Darr(Dic.Item(TMP), 4) + Darr(Dic.Item(TMP), 3)
Em gửi lại file đính kèm thật, nhờ anh chị xem lại giúp
Em cảm ơn

PHP:

Sub abc()
Dim arr(), Darr(1 To 65536, 1 To 5), SheetName()
Dim tungay, denngay, i, j, x, k, tmp
SheetNames = Array("V-ban", "KDT-ban")
tungay = Sheets("TK_THANG").[D2].Value
dengnay = Sheets("TK_THANG").[D3].Value
With CreateObject("scripting.dictionary")
   For x = 0 To UBound(SheetNames)
      With Sheets(SheetNames(x))
         arr = .Range("A3", .[A65536].End(3)).Resize(, 4).Value
      End With
      For i = 1 To UBound(arr)
         tmp = arr(i, 2)
         If arr(i, 1) >= tungay Then
            If arr(i, 1) <= dengnay Then
               If Not .exists(tmp) Then
                  k = k + 1
                  .Add tmp, k
                  Darr(k, 1) = tmp
                  Darr(k, 2) = arr(i, 3)
                  Darr(k, x + 3) = Darr(k, x + 3) + arr(i, 4)
               Else
                  j = .Item(tmp)
                  Darr(j, x + 3) = Darr(j, x + 3) + arr(i, 4)
               End If
               Darr(.Item(tmp), 5) = Darr(.Item(tmp), 3) + Darr(.Item(tmp), 4)
            End If
         End If
      Next
   Next
End With
Sheets("TK_THANG").[A6].Resize(k, 5) = Darr
End Sub

bongmaihung · 1/4/15

quanghai1969 đã viết:

PHP:

Sub abc()
Dim arr(), Darr(1 To 65536, 1 To 5), SheetName()
Dim tungay, denngay, i, j, x, k, tmp
SheetNames = Array("V-ban", "KDT-ban")
tungay = Sheets("TK_THANG").[D2].Value
dengnay = Sheets("TK_THANG").[D3].Value
With CreateObject("scripting.dictionary")
   For x = 0 To UBound(SheetNames)
      With Sheets(SheetNames(x))
         arr = .Range("A3", .[A65536].End(3)).Resize(, 4).Value
      End With
      For i = 1 To UBound(arr)
         tmp = arr(i, 2)
         If arr(i, 1) >= tungay Then
            If arr(i, 1) <= dengnay Then
               If Not .exists(tmp) Then
                  k = k + 1
                  .Add tmp, k
                  Darr(k, 1) = tmp
                  Darr(k, 2) = arr(i, 3)
                  Darr(k, x + 3) = Darr(k, x + 3) + arr(i, 4)
               Else
                  j = .Item(tmp)
                  Darr(j, x + 3) = Darr(j, x + 3) + arr(i, 4)
               End If
               Darr(.Item(tmp), 5) = Darr(.Item(tmp), 3) + Darr(.Item(tmp), 4)
            End If
         End If
      Next
   Next
End With
Sheets("TK_THANG").[A6].Resize(k, 5) = Darr
End Sub

Tuyệt vời, em cảm ơn anh

Lọc trùng và tính tổng cộng bằng Dictionary (1 người xem)

Người dùng đang xem chủ đề này

bongmaihung

Thành viên hoạt động

File đính kèm

giangleloi

Thành viên gắn bó

bongmaihung

Thành viên hoạt động

bongmaihung

Thành viên hoạt động

File đính kèm

Quang_Hải

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

bongmaihung

Thành viên hoạt động

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

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.