Giúp code Lọc cùng ngày và cùng mã và một số điều kiện khác! (1 người xem)

Hong.Van · 26/9/12

Em chào Thầy cô & anh chị!
Giúp em code nếu cùng ngày và cùng mã và một số điều kiện khác thì trích lọc
Em có mô tả và ví dụ trong File
em cảm ơn!

ThuNghi · 26/9/12

Hong.Van đã viết:
Em chào Thầy cô & anh chị!
Giúp em code nếu cùng ngày và cùng mã và một số điều kiện khác thì trích lọc
Em có mô tả và ví dụ trong File
em cảm ơn!

Cũng là bài trích lọc mà.
1/ nếu muốn text thì format trước khi gán xuống.
2/ Nếu muốn sort thì gán xuống sau đó sort. Vì chưa vận dụng dc code sort của Bác Siwton

PHP:

Sub TrichLoc()
Dim i&, s&, eR&, nR&
Dim tmpStr$
Dim sArr(), lArr(), rArr()
Dim Dic As Object
Set Dic = CreateObject("Scripting.Dictionary")
With Sheets("NhapMua")
  eR = .Cells(65000, 2).End(xlUp).Row
  lArr = .Range("B18:B" & eR).Value
  sArr = .Range("E18:N" & eR).Value
End With
ReDim rArr(1 To 1000, 1 To 4)
For i = 1 To UBound(lArr)
  If lArr(i, 1) <> 2 Then
    If lArr(i, 1) <> 5 Then
      tmpStr = sArr(i, 1) & sArr(i, 2) & sArr(i, 4)
      If Not Dic.Exists(tmpStr) Then
        s = s + 1
        Dic.Add tmpStr, s
        rArr(s, 1) = CStr(sArr(i, 1)) 'SoHD
        rArr(s, 2) = CVDate(sArr(i, 2)) 'NgayHD
        rArr(s, 3) = CStr(sArr(i, 4)) 'MST
      End If
      nR = Dic.Item(tmpStr)
      rArr(nR, 4) = rArr(nR, 4) + sArr(i, 10)
    End If
  End If
Next i
If s Then
  With Sheets("NhapMua")
    .[R18].Resize(1000, 4).ClearContents
    .[R18].Resize(s, 4) = rArr
  End With
End If
Erase sArr(), lArr(), rArr()
Set Dic = Nothing
'MsgBox s
End Sub

Hong.Van · 26/9/12

ThuNghi đã viết:

Cũng là bài trích lọc mà.
1/ nếu muốn text thì format trước khi gán xuống.
2/ Nếu muốn sort thì gán xuống sau đó sort. Vì chưa vận dụng dc code sort của Bác Siwton

PHP:

Sub TrichLoc()
Dim i&, s&, eR&, nR&
Dim tmpStr$
Dim sArr(), lArr(), rArr()
Dim Dic As Object
Set Dic = CreateObject("Scripting.Dictionary")
With Sheets("NhapMua")
  eR = .Cells(65000, 2).End(xlUp).Row
  lArr = .Range("B18:B" & eR).Value
  sArr = .Range("E18:N" & eR).Value
End With
ReDim rArr(1 To 1000, 1 To 4)
For i = 1 To UBound(lArr)
  If lArr(i, 1) <> 2 Then
    If lArr(i, 1) <> 5 Then
      tmpStr = sArr(i, 1) & sArr(i, 2) & sArr(i, 4)
      If Not Dic.Exists(tmpStr) Then
        s = s + 1
        Dic.Add tmpStr, s
        rArr(s, 1) = CStr(sArr(i, 1)) 'SoHD
        rArr(s, 2) = CVDate(sArr(i, 2)) 'NgayHD
        rArr(s, 3) = CStr(sArr(i, 4)) 'MST
      End If
      nR = Dic.Item(tmpStr)
      rArr(nR, 4) = rArr(nR, 4) + sArr(i, 10)
    End If
  End If
Next i
If s Then
  With Sheets("NhapMua")
    .[R18].Resize(1000, 4).ClearContents
    .[R18].Resize(s, 4) = rArr
  End With
End If
Erase sArr(), lArr(), rArr()
Set Dic = Nothing
'MsgBox s
End Sub

Code của thầy chỉ lọc bỏ Lọai 2 & lọai 5 thôi, nhờ Thầy xem lại
Yêu cầu của em là
Mục 1/ Không lọc Loại 2 và Loại 5 ỏ cột B cho dù thỏa điều kiện Mục 2 ở dưới đây
Mục 2/ Nếu cùng Mã số (cột H) VÀ cùng ngày, tháng, năm (cột F) VÀ Lọai có thể là: Lọai 1 HOẶC Lọai 3 HOẶC Loại 4. Nếu cộng tiền (Nghĩa là tổng cộng tiền thỏa ở điều kiện đầu của mục 2) bằng hoặc lớn hơn 20 triệu thì liệt kê như bảng trong File đính kèm
Em cảm ơn!

ThuNghi · 26/9/12

Hong.Van đã viết:
Code của thầy chỉ lọc bỏ Lọai 2 & lọai 5 thôi, nhờ Thầy xem lại
Yêu cầu của em là
Mục 1/ Không lọc Loại 2 và Loại 5 ỏ cột B cho dù thỏa điều kiện Mục 2 ở dưới đây
Mục 2/ Nếu cùng Mã số (cột H) VÀ cùng ngày, tháng, năm (cột F) VÀ Lọai có thể là: Lọai 1 HOẶC Lọai 3 HOẶC Loại 4. Nếu cộng tiền (Nghĩa là tổng cộng tiền thỏa ở điều kiện đầu của mục 2) bằng hoặc lớn hơn 20 triệu thì liệt kê như bảng trong File đính kèm
Em cảm ơn!

Nếu thêm Dic thì OK
Thắc mắc sao màu đên kg thỏa.
vd sohd 311188

Hong.Van · 26/9/12

thunghi đã viết:
nếu thêm dic thì ok
thắc mắc sao màu đên kg thỏa.
Vd sohd 311188

Số hóa đơn 311188 và 311189, là lọai 1 (lọai nào cũng được miễn kh fải là lọai 2 và lọai 5), có cùng ngày 11/01/12, có cùng mã số 0304722166, có số tiền lần lượt là 7.619.999 và 605.000, nhưng cộng hai số tiền này lại là 8.224.999 vẫn nhỏ hơn 20 triệu, nên không lọc
-------------
Mục đích em lọc những hóa đơn có cùng ngày cùng mã số mà Tổng tiền bằng lớn hơn 20 triệu!
Em cảm ơn!

ThuNghi · 26/9/12

Hong.Van đã viết:
Số hóa đơn 311188 và 311189, là lọai 1 (lọai nào cũng được miễn kh fải là lọai 2 và lọai 5), có cùng ngày 11/01/12, có cùng mã số 0304722166, có số tiền lần lượt là 7.619.999 và 605.000, nhưng cộng hai số tiền này lại là 8.224.999 vẫn nhỏ hơn 20 triệu, nên không lọc
-------------
Mục đích em lọc những hóa đơn có cùng ngày cùng mã số mà Tổng tiền bằng lớn hơn 20 triệu!
Em cảm ơn!

Vậy hd 9431104 thì sao?

Quang_Hải · 26/9/12

Hong.Van đã viết:
Em chào Thầy cô & anh chị!
Giúp em code nếu cùng ngày và cùng mã và một số điều kiện khác thì trích lọc
Em có mô tả và ví dụ trong File
em cảm ơn!

Hình như chưa hiểu hết ý của bạn, viết thế này xem sao nha. Hên xui hén

Xem kỹ lại bài cuối của HV thì code chưa đúng rồi, còn thêm dk tổng > 20tr nữa

PHP:

Private Sub CommandButton1_Click()
Dim dl, kq(1 To 1000, 1 To 4), i, j, k
dl = Range([b18], [b65536].End(3)).Resize(, 13).Value
For i = 1 To UBound(dl)
  If dl(i, 1) = 1 Or dl(i, 1) = 3 Or dl(i, 1) = 4 Then
    If dl(i, 13) >= 20000000 Then
      k = k + 1
        kq(k, 1) = dl(i, 4)
          kq(k, 2) = dl(i, 5)
            kq(k, 3) = dl(i, 7)
              kq(k, 4) = dl(i, 13)
    Else
      For j = 1 To UBound(dl)
        If dl(i, 7) = dl(j, 7) Then
          If dl(i, 5) = dl(j, 5) Then
            If j <> i Then
              k = k + 1
                kq(k, 1) = dl(i, 4)
                  kq(k, 2) = dl(i, 5)
                    kq(k, 3) = dl(i, 7)
                      kq(k, 4) = dl(i, 13)
                        Exit For
            End If
          End If
        End If
      Next
    End If
  End If
Next
[x18].Resize(k).NumberFormat = "@"
[v18].Resize(k + 1, 4) = kq
End Sub

Hong.Van · 26/9/12

ThuNghi đã viết:
Vậy hd 9431104 thì sao?

Các HĐơn từ 9431102 đến 9431106 có cùng ngày và cùng mã, nhưng HĐ 9431103 là lọai 2 và HĐ 9431106 là lọai 5 nên loại bỏ không lọc. Bây giờ cộng số tiền của HĐ còn lại là 9431102 (11.799.167 đ) và 9431104 (1.441.871 đ) và 9431105 (9.201.894 đ), tổng số tiền 3 HĐ là 22.442.932 > 20 triệu => Thỏa điều kiện => lọc 3 HĐ này.
Em cảm ơn!

ndu96081631 · 26/9/12

quanghai1969 đã viết:
Hình như chưa hiểu hết ý của bạn, viết thế này xem sao nha. Hên xui hén

Xem kỹ lại bài cuối của HV thì code chưa đúng rồi, còn thêm dk tổng > 20tr nữa

Bài này nêu không có Dictionary thì thua đồng chí à! Vì còn phải gom mấy trường lại với nhau rồi xét sự tồn tại, tiếp theo phải cộng dồn tổng nữa

Quang_Hải · 26/9/12

ndu96081631 đã viết:
Bài này nêu không có Dictionary thì thua đồng chí à! Vì còn phải gom mấy trường lại với nhau rồi xét sự tồn tại, tiếp theo phải cộng dồn tổng nữa

Em cũng tính ráng thử không dùng dic vì em thấy có hướng xử. Code lại thế này thì ra kết quả nhưng chưa biết có phát sinh gì hay không

PHP:

Private Sub CommandButton1_Click()
Dim dl, kq(1 To 1000, 1 To 4), i, j, k, m
dl = Range([b18], [b65536].End(3)).Resize(, 13).Value
For i = 1 To UBound(dl)
  If dl(i, 1) = 1 Or dl(i, 1) = 3 Or dl(i, 1) = 4 Then
    If dl(i, 13) >= 20000000 Then
      k = k + 1
        kq(k, 1) = dl(i, 4)
          kq(k, 2) = dl(i, 5)
            kq(k, 3) = dl(i, 7)
              kq(k, 4) = dl(i, 13)
    Else
      For j = 1 To UBound(dl)
        If dl(i, 7) = dl(j, 7) Then
          If dl(i, 5) = dl(j, 5) Then
            If j <> i Then
              If (dl(i, 13) + dl(j, 13)) + m >= 20000000 Then
                k = k + 1
                  kq(k, 1) = dl(i, 4)
                    kq(k, 2) = dl(i, 5)
                      kq(k, 3) = dl(i, 7)
                        kq(k, 4) = dl(i, 13)
                          Exit For
              ElseIf (dl(i, 13) + dl(j, 13)) < 20000000 Then
                m = (dl(i, 13) + dl(j, 13))
              End If
            End If
          End If
        End If
      Next
    End If
  End If
Next
[x18].Resize(k).NumberFormat = "@"
[v18].Resize(k + 1, 4) = kq
End Sub

Hong.Van · 26/9/12

quanghai1969 đã viết:

Em cũng tính ráng thử không dùng dic vì em thấy có hướng xử. Code lại thế này thì ra kết quả nhưng chưa biết có phát sinh gì hay không

PHP:

Private Sub CommandButton1_Click()
Dim dl, kq(1 To 1000, 1 To 4), i, j, k, m
dl = Range([b18], [b65536].End(3)).Resize(, 13).Value
For i = 1 To UBound(dl)
  If dl(i, 1) = 1 Or dl(i, 1) = 3 Or dl(i, 1) = 4 Then
    If dl(i, 13) >= 20000000 Then
      k = k + 1
        kq(k, 1) = dl(i, 4)
          kq(k, 2) = dl(i, 5)
            kq(k, 3) = dl(i, 7)
              kq(k, 4) = dl(i, 13)
    Else
      For j = 1 To UBound(dl)
        If dl(i, 7) = dl(j, 7) Then
          If dl(i, 5) = dl(j, 5) Then
            If j <> i Then
              If (dl(i, 13) + dl(j, 13)) + m >= 20000000 Then
                k = k + 1
                  kq(k, 1) = dl(i, 4)
                    kq(k, 2) = dl(i, 5)
                      kq(k, 3) = dl(i, 7)
                        kq(k, 4) = dl(i, 13)
                          Exit For
              ElseIf (dl(i, 13) + dl(j, 13)) < 20000000 Then
                m = (dl(i, 13) + dl(j, 13))
              End If
            End If
          End If
        End If
      Next
    End If
  End If
Next
[x18].Resize(k).NumberFormat = "@"
[v18].Resize(k + 1, 4) = kq
End Sub

Tại bài #1 của em, sửa cell B28 thành Loại 1 hoặc loại 3 hay lọai 4, số tiền của hóa đơn này ( số HĐ 26552) 18.000.000 <20 triệu => Sai , nhưng nó vẫn lọc.
Anh xem lại giúp em
xin cảm ơn!

concogia · 26/9/12

Cứ "Đít - to" mà phang cho nó, chẳng chạy đâu được. Đây là một cách ( mà mấy cái kế toán rắc rối nhỉ )

Mã:

Public Sub Loc()
    Dim Vung, I, d, Gom, Mg, K
    Set d = CreateObject("scripting.dictionary")
    Vung = Range([B18], [B10000].End(xlUp)).Resize(, 13)
    ReDim Mg(1 To UBound(Vung), 1 To 4)
        For I = 1 To UBound(Vung)
            If Vung(I, 1) <> 2 And Vung(I, 1) <> 5 Then
                Gom = Vung(I, 5) & " " & Vung(I, 7)
                    If Not d.exists(Gom) Then
                        d.Add Gom, Vung(I, 13)
                    Else
                        d.Item(Gom) = d.Item(Gom) + Vung(I, 13)
                    End If
            End If
        Next I
                For I = 1 To UBound(Vung)
                    If Vung(I, 1) <> 2 And Vung(I, 1) <> 5 Then
                        Gom = Vung(I, 5) & " " & Vung(I, 7)
                            If d.exists(Gom) Then
                                If d.Item(Gom) > 20000000 Then
                                    K = K + 1
                                    Mg(K, 1) = Vung(I, 4): Mg(K, 2) = Vung(I, 5): Mg(K, 3) = Vung(I, 7): Mg(K, 4) = Vung(I, 13)
                                End If
                            End If
                    End If
                Next I
    [W18].Resize(1000, 4).ClearContents
    [W18].Resize(K, 4) = Mg
End Sub

Kết quả ra ở [W18]
Thân

Quang_Hải · 26/9/12

Hong.Van đã viết:
Tại bài #1 của em, sửa cell B28 thành Loại 1 hoặc loại 3 hay lọai 4, số tiền của hóa đơn này ( số HĐ 26552) 18.000.000 <20 triệu => Sai , nhưng nó vẫn lọc.
Anh xem lại giúp em
xin cảm ơn!

Xét thêm 1 Dk nữa xem thế nào, quyết tâm không xài Dic coi sao

PHP:

Private Sub CommandButton1_Click()
Dim dl, kq(1 To 1000, 1 To 4), i, j, k, m
dl = Range([b18], [b65536].End(3)).Resize(, 13).Value
For i = 1 To UBound(dl)
  If dl(i, 1) = 1 Or dl(i, 1) = 3 Or dl(i, 1) = 4 Then
    If dl(i, 13) >= 20000000 Then
      k = k + 1
        kq(k, 1) = dl(i, 4)
          kq(k, 2) = dl(i, 5)
            kq(k, 3) = dl(i, 7)
              kq(k, 4) = dl(i, 13)
    Else
      For j = 1 To UBound(dl)
        If dl(i, 7) = dl(j, 7) Then
          If dl(i, 5) = dl(j, 5) Then
            If j <> i Then
              If dl(j, 1) = 1 Or dl(j, 1) = 3 Or dl(j, 1) = 4 Then
                If (dl(i, 13) + dl(j, 13)) + m >= 20000000 Then
                  k = k + 1
                  kq(k, 1) = dl(i, 4)
                    kq(k, 2) = dl(i, 5)
                      kq(k, 3) = dl(i, 7)
                        kq(k, 4) = dl(i, 13)
                          Exit For
                ElseIf (dl(i, 13) + dl(j, 13)) < 20000000 Then
                  m = (dl(i, 13) + dl(j, 13))
                End If
              End If
            End If
          End If
        End If
      Next
    End If
  End If
Next
[x18].Resize(k).NumberFormat = "@"
[v18].Resize(k + 1, 4) = kq
End Sub

ThuNghi · 26/9/12

Hong.Van đã viết:
Các HĐơn từ 9431102 đến 9431106 có cùng ngày và cùng mã, nhưng HĐ 9431103 là lọai 2 và HĐ 9431106 là lọai 5 nên loại bỏ không lọc. Bây giờ cộng số tiền của HĐ còn lại là 9431102 (11.799.167 đ) và 9431104 (1.441.871 đ) và 9431105 (9.201.894 đ), tổng số tiền 3 HĐ là 22.442.932 > 20 triệu => Thỏa điều kiện => lọc 3 HĐ này.
Em cảm ơn!

Do đọc không kỹ.

PHP:

Sub TrichLoc()
Dim i&, s&, eR&, nR&, k&
Dim tmpStr$
Dim sArr(), lArr(), rArr(), tmpArr(), SoHD, SoTien
Dim Dic As Object
Set Dic = CreateObject("Scripting.Dictionary")
With Sheets("NhapMua")
  eR = .Cells(65000, 2).End(xlUp).Row
  lArr = .Range("B18:B" & eR).Value
  sArr = .Range("E18:N" & eR).Value
End With
ReDim tmpArr(1 To 1000, 1 To 5)
For i = 1 To UBound(lArr)
  If lArr(i, 1) <> 2 Then
    If lArr(i, 1) <> 5 Then
      tmpStr = sArr(i, 2) & "-" & sArr(i, 4)
      If Not Dic.Exists(tmpStr) Then
        s = s + 1
        Dic.Add tmpStr, s
        tmpArr(s, 2) = CVDate(sArr(i, 2)) 'NgayHD
        tmpArr(s, 3) = CStr(sArr(i, 4)) 'MST
      End If
      nR = Dic.Item(tmpStr)
      tmpArr(nR, 4) = tmpArr(nR, 4) + sArr(i, 10)
      If Len(tmpArr(nR, 1)) > 0 Then
        tmpArr(nR, 1) = tmpArr(nR, 1) & vbBack & CStr(sArr(i, 1)) 'SoHD
        tmpArr(nR, 5) = tmpArr(nR, 5) & vbBack & CStr(sArr(i, 10)) 'SoTien
      Else
        tmpArr(nR, 1) = CStr(sArr(i, 1)) 'SoHD
        tmpArr(nR, 5) = CStr(sArr(i, 10)) 'SoTien
      End If
    End If
  End If
Next i
'Duyet qua de lay > 20 tr'
ReDim rArr(1 To s, 1 To 4)
nR = 1
For i = 1 To s
  If tmpArr(i, 4) > 20000000 Then
    'nR = nR + 1
    SoHD = Split(tmpArr(i, 1), vbBack)
    SoTien = Split(tmpArr(i, 5), vbBack)
    For k = 0 To UBound(SoHD)
      rArr(nR, 1) = SoHD(k)
      rArr(nR, 2) = CVDate(tmpArr(i, 2)) 'Ngay
      rArr(nR, 3) = CStr(tmpArr(i, 3)) 'MST
      rArr(nR, 4) = SoTien(k) 'soTien
      nR = nR + 1
    Next k
  End If
Next i
If nR Then
  With Sheets("NhapMua")
    .[R18].Resize(1000, 4).ClearContents
    .[R18].Resize(s, 4) = rArr
  End With
End If
Erase sArr(), lArr(), tmpArr(), rArr(), SoTien, SoHD
Set Dic = Nothing
End Sub

Hong.Van · 26/9/12

Em đã kiểm tra thấy bài #12 & #13 & #14 chạy ổn, chưa thấy fát sinh gì thêm!
bài #13 của anh Quanghai, thiếu 1 tý là chưa xóa dữ liệu cũ trước khi chạy code.
Em xin cảm ơn tất cả các Thầy & anh đã giúp em bài này.

Ba Tê · 26/9/12

Hong.Van đã viết:
Em chào Thầy cô & anh chị!
Giúp em code nếu cùng ngày và cùng mã và một số điều kiện khác thì trích lọc
Em có mô tả và ví dụ trong File
em cảm ơn!

Điều kiện là tổng cột tiền >=20 triệu, trong kết quả ví dụ vẫn có cột tiền <20 triệu là sao?

| R
| S
| T
| U
|
16
| Số hoá đơn
| Ngày, tháng, năm
| Mã số
| Tiền
|
17
|

[1]

|

[2]

|

[3]

|

[4]

|
18
|

579

|

01/01/2012

|

305.216.236

|

19.652.500

|
19
|

22.740

|

07/01/2012

|

303.688.794

|

395.000.000

|
20
|

9.431.102

|

13/01/2012

|

300.954.529

|

11.799.167

|
21
|

9.431.104

|

13/01/2012

|

300.954.529

|

1.441.871

|
22
|

9.431.105

|

13/01/2012

|

300.954.529

|

9.201.894

|
23
|

1.158

|

13/01/2012

|

3.600.591.656

|

19.950.000

|
24
|

1.168

|

13/01/2012

|

3.600.591.656

|

19.950.000

|
25
|

580

|

01/01/2012

|

305.216.236

|

9.652.500

|
26
|

23.234

|

04/02/2012

|

303.688.794

|

475.200.000

|

Nếu code này không đúng thì "hết hiểu".

PHP:

Public Sub GPE()
Dim Rng(), Arr(), Arr2(), I As Long, j As Long, K As Long, Dic As Object, Tem As Variant, Str As String, Ma As String, N As Long
Set Dic = CreateObject("Scripting.Dictionary")
    Rng = Range([b18], [B65000].End(xlUp)).Resize(, 13).Value
ReDim Arr(1 To UBound(Rng, 1), 1 To 4)
ReDim Arr2(1 To UBound(Rng, 1), 1 To 4)
    For I = 1 To UBound(Rng, 1)
            Tem = Rng(I, 1)
        If Tem <> "" Then
            If Tem <> 2 And Tem <> 5 Then
                Ma = Rng(I, 1) & Rng(I, 5) & Rng(I, 7)
                If Not Dic.Exists(Ma) Then
                    K = K + 1
                    Dic.Add Ma, K
                    Arr(K, 1) = Rng(I, 4)
                    Arr(K, 2) = Rng(I, 5)
                    Arr(K, 3) = Rng(I, 7)
                    Arr(K, 4) = Rng(I, 13)
                Else
                    Arr(Dic.Item(Ma), 4) = Arr(Dic.Item(Ma), 4) + Rng(I, 13)
                End If
            End If
        End If
    Next I
        For I = 1 To K
            If Arr(I, 4) >= 20000000 Then
                    N = N + 1
                For j = 1 To 4
                    Arr2(N, j) = Arr(I, j)
                Next j
            End If
        Next I
    [R18:U10000].ClearContents
    [r18].Resize(N, 4).Value = Arr2
Set Dic = Nothing
End Sub

concogia · 26/9/12

Ba Tê đã viết:

Điều kiện là tổng cột tiền >=20 triệu, trong kết quả ví dụ vẫn có cột tiền <20 triệu là sao?

Nếu code này không đúng thì "hết hiểu".

PHP:

Public Sub GPE()
Dim Rng(), Arr(), Arr2(), I As Long, j As Long, K As Long, Dic As Object, Tem As Variant, Str As String, Ma As String, N As Long
Set Dic = CreateObject("Scripting.Dictionary")
    Rng = Range([b18], [B65000].End(xlUp)).Resize(, 13).Value
ReDim Arr(1 To UBound(Rng, 1), 1 To 4)
ReDim Arr2(1 To UBound(Rng, 1), 1 To 4)
    For I = 1 To UBound(Rng, 1)
            Tem = Rng(I, 1)
        If Tem <> "" Then
            If Tem <> 2 And Tem <> 5 Then
                Ma = Rng(I, 1) & Rng(I, 5) & Rng(I, 7)
                If Not Dic.Exists(Ma) Then
                    K = K + 1
                    Dic.Add Ma, K
                    Arr(K, 1) = Rng(I, 4)
                    Arr(K, 2) = Rng(I, 5)
                    Arr(K, 3) = Rng(I, 7)
                    Arr(K, 4) = Rng(I, 13)
                Else
                    Arr(Dic.Item(Ma), 4) = Arr(Dic.Item(Ma), 4) + Rng(I, 13)
                End If
            End If
        End If
    Next I
        For I = 1 To K
            If Arr(I, 4) >= 20000000 Then
                    N = N + 1
                For j = 1 To 4
                    Arr2(N, j) = Arr(I, j)
                Next j
            End If
        Next I
    [R18:U10000].ClearContents
    [r18].Resize(N, 4).Value = Arr2
Set Dic = Nothing
End Sub

Hihi, hoan hô anh Ba Tê đã cho ra một kết quả....trật lấc
90% anh Ba Tê cóc có làm kế toán được
Bài đó như thế này nè
1)- Những hóa đơn nào có Loại (cột B) là 1, 3 & 4 mới tính ( 2 & 5 "nô tế bồ")
2)- Những hóa đơn nào mà trùng về "Ngày" (cột F) và "Mã số" (cột H) và tổng số tiền (cột N) của chúng nó phải lớn hơn 20 triệu thì liệt kê chúng nó ra
3)- Trong bảng Ba Tê nhìn thấy có hóa đơn dưới 20 triệu vẫn liệt kê vì ........nó thỏa điều kiện
Thí dụ: Hoá đơn số 579 Ngày 01/01/2012 Mã số 305.216.236 số tiền 19.652.500 ( nhỏ hơn 20 triệu, hihi) trùng Ngày & Mã số với số hóa đơn 580 có số tiền là 9.652.500. Số tiền của 2 em này cộng lại lớn hơn 20 triệu ==> thỏa ==> liệt kê 2 em đó ra
Tương tự, số hóa đơn 1158 trùng với 1168; 22740 trùng với 23234......
Híc

Ba Tê · 26/9/12

concogia đã viết:
Hihi, hoan hô anh Ba Tê đã cho ra một kết quả....trật lấc
90% anh Ba Tê cóc có làm kế toán được
Bài đó như thế này nè
1)- Những hóa đơn nào có Loại (cột B) là 1, 3 & 4 mới tính ( 2 & 5 "nô tế bồ")
2)- Những hóa đơn nào mà trùng về "Ngày" (cột F) và "Mã số" (cột H) và tổng số tiền (cột N) của chúng nó phải lớn hơn 20 triệu thì liệt kê chúng nó ra
3)- Trong bảng Ba Tê nhìn thấy có hóa đơn dưới 20 triệu vẫn liệt kê vì ........nó thỏa điều kiện
Thí dụ: Hoá đơn số 579 Ngày 01/01/2012 Mã số 305.216.236 số tiền 19.652.500 ( nhỏ hơn 20 triệu, hihi) trùng Ngày & Mã số với số hóa đơn 580 có số tiền là 9.652.500. Số tiền của 2 em này cộng lại lớn hơn 20 triệu ==> thỏa ==> liệt kê 2 em đó ra
Tương tự, số hóa đơn 1158 trùng với 1168; 22740 trùng với 23234......
Híc

Úi da! Đọc câu này mơ mơ hồ hồ!

2)- Những hóa đơn nào mà trùng về "Ngày" (cột F) và "Mã số" (cột H) và tổng số tiền (cột N) của chúng nó phải lớn hơn 20 triệu thì liệt kê chúng nó ra

Thật tình tui không làm kế toán được "gồi".
Dong thôi Cò ơi!
Híc!!!

sealand · 27/9/12

Với dữ liệu này thấy OK, không hiểu còn lỗi gì không với số lượng nhiều hơn

Mã:

Sub Loc()
Dim Tm, i, j, n, Ky, It, Kq(), Dic As Object
Set Dic = CreateObject("Scripting.Dictionary")
Tm = Sheet10.[B18:N18].Resize(Sheet10.[B65536].End(3).Row - 17)
For i = 1 To UBound(Tm, 1)
If Tm(i, 1) <> 2 And Tm(i, 1) <> 5 Then
If Not Dic.exists(Tm(i, 5) & Tm(i, 7)) Then
Dic.Add Tm(i, 5) & Tm(i, 7), Tm(i, 13)
Else
Dic.Item(Tm(i, 5) & Tm(i, 7)) = Val(Dic.Item(Tm(i, 5) & Tm(i, 7))) + Val(Tm(i, 13))
End If
End If
Next
Ky = Dic.keys: It = Dic.items
For i = Dic.Count - 1 To 0 Step -1
If Val(It(i)) < 20000000 Then Dic.Remove (Ky(i))
Next
For i = 1 To UBound(Tm, 1)
If Tm(i, 1) <> 2 And Tm(i, 1) <> 5 Then
If Dic.exists(Tm(i, 5) & Tm(i, 7)) Then
j = j + 1
ReDim Preserve Kq(1 To 4, 1 To j)
Kq(1, j) = Tm(i, 4)
Kq(2, j) = Tm(i, 5)
Kq(3, j) = Tm(i, 7)
Kq(4, j) = Tm(i, 13)
End If
End If
Next
Sheet10.[R18:U65536].ClearContents
Sheet10.[R18].Resize(j, 4) = WorksheetFunction.Transpose(Kq)
Set Dic = Nothing
End Sub

Hai Lúa Miền Tây · 27/9/12

Đã đọc bài toán này, thèm được áp dụng ADO nhưng thật tình mà nói mình chưa hiểu hết các điều kiện để lọc, còn rất mơ hồ. Anh ThuNghi có cao kiến gì không chỉ cho em với.

ThuNghi · 27/9/12

Hai Lúa Miền Tây đã viết:
Đã đọc bài toán này, thèm được áp dụng ADO nhưng thật tình mà nói mình chưa hiểu hết các điều kiện để lọc, còn rất mơ hồ. Anh ThuNghi có cao kiến gì không chỉ cho em với.

Bài loại này mà dùng ADO thì quá hay nhưng hiện tại chưa rành câu select lồng mà chỉ biết chạy ADO 2 lần.
Để cụ thể bài trên cho HL nhé.
Trong này Makh # Ngay&MST file trên.

sealand · 27/9/12

Mình thay lời tác giả chút, đây là bài toán liệt kê tất cả các hoá đơn mua hàng phải thanh toán qua ngân hàng:

1/Các hoá đơn có giá trị trên 20 triệu.
2/Các hoá đơn mua của 1 nhà cung cấp trong cùng ngày có tổng trị giá trên 20 triệu (Kể cả hoá đơn riêng lẻ có giá trị nhỏ hơn 20 triệu)

Loại 2 bị loại: 2.Hàng hoá, dịch vụ không đủ điều kiện khấu trừ.
Loại 5 bị loại: 5.Hàng hoá dịch vụ không phải tổng hợp trên tờ khai 01/GTGT.

Dữ liệu này kết xuất từ phần mềm HTKK 3.1.3 ra sử lý chút là được

Với mức kê khai tháng và số Hóa đơn đầu vào của 1 doanh nghiệp thì việc sử dung ADO hơi cồng kềnh 1 chút, đôi khi tốc độ không ăn được đánh du kích.

Hi, không hiểu bói có trúng không nưã!!!

Hong.Van · 27/9/12

sealand đã viết:
Mình thay lời tác giả chút, đây là bài toán liệt kê tất cả các hoá đơn mua hàng phải thanh toán qua ngân hàng:

1/Các hoá đơn có giá trị trên 20 triệu.
2/Các hoá đơn mua của 1 nhà cung cấp trong cùng ngày có tổng trị giá trên 20 triệu (Kể cả hoá đơn riêng lẻ có giá trị nhỏ hơn 20 triệu)

Loại 2 bị loại: 2.Hàng hoá, dịch vụ không đủ điều kiện khấu trừ.
Loại 5 bị loại: 5.Hàng hoá dịch vụ không phải tổng hợp trên tờ khai 01/GTGT.

Hi, không hiểu bói có trúng không nưã!!!

Chính xác ..............
Bổ sung: có tổng trị giá bằng hoặc trên 20 triệu

Hai Lúa Miền Tây · 27/9/12

ThuNghi đã viết:
Bài loại này mà dùng ADO thì quá hay nhưng hiện tại chưa rành câu select lồng mà chỉ biết chạy ADO 2 lần.
Để cụ thể bài trên cho HL nhé.
Trong này Makh # Ngay&MST file trên.

Em làm thử theo ví dụ của anh ThuNghi gửi như sau:

Mã:

Sub TrichLoc()
Dim cnn As New ADODB.Connection
Dim adoRS As New ADODB.Recordset
Dim mySQL As String
With cnn
    .ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
                        "Data Source=" & ThisWorkbook.FullName & _
                        ";Extended Properties=""Excel 8.0;HDR=Yes;"";"
    .Open
End With
With adoRS
    .CursorLocation = adUseClient
    .CursorType = adOpenStatic
    .ActiveConnection = cnn
    mySQL = "SELECT [Sheet1$].[IDNo], [Sheet1$].[Makh], [Sheet1$].[ST] " & _
                    "FROM [Sheet1$] INNER JOIN (SELECT [Sheet1$].[Makh], Sum([Sheet1$].[ST]) AS [SumOfST] " & _
                    "FROM [Sheet1$] " & _
                    "GROUP BY [Sheet1$].[Makh] " & _
                    "HAVING (((Sum([Sheet1$].[ST]))>8))) AS a ON [Sheet1$].[Makh] = [a].[Makh] " & _
                    "WHERE (((a.[SumOfST])>8)) " & _
                    "order by [Sheet1$].[Makh],[Sheet1$].[IDNo]; "
    .Open mySQL
End With
With Sheet1
    [G2:I600].ClearContents
    For i = 0 To (adoRS.Fields.Count - 1)
        .Cells(1, i + 7) = adoRS.Fields(i).Name
    Next
    .Range("g2").CopyFromRecordset adoRS
    
End With
adoRS.Close: Set adoRS = Nothing: cnn.Close: Set cnn = Nothing

End Sub

ThuNghi · 27/9/12

Hai Lúa Miền Tây đã viết:

Em làm thử theo ví dụ của anh ThuNghi gửi như sau:

Mã:

Sub TrichLoc()
Dim cnn As New ADODB.Connection
Dim adoRS As New ADODB.Recordset
Dim mySQL As String
With cnn
    .ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
                        "Data Source=" & ThisWorkbook.FullName & _
                        ";Extended Properties=""Excel 8.0;HDR=Yes;"";"
    .Open
End With
With adoRS
    .CursorLocation = adUseClient
    .CursorType = adOpenStatic
    .ActiveConnection = cnn
    mySQL = "SELECT [Sheet1$].[IDNo], [Sheet1$].[Makh], [Sheet1$].[ST] " & _
                    "FROM [Sheet1$] INNER JOIN (SELECT [Sheet1$].[Makh], Sum([Sheet1$].[ST]) AS [SumOfST] " & _
                    "FROM [Sheet1$] " & _
                    "GROUP BY [Sheet1$].[Makh] " & _
                    "HAVING (((Sum([Sheet1$].[ST]))>8))) AS a ON [Sheet1$].[Makh] = [a].[Makh] " & _
                    "WHERE (((a.[SumOfST])>8)) " & _
                    "order by [Sheet1$].[Makh],[Sheet1$].[IDNo]; "
    .Open mySQL
End With
With Sheet1
    [G2:I600].ClearContents
    For i = 0 To (adoRS.Fields.Count - 1)
        .Cells(1, i + 7) = adoRS.Fields(i).Name
    Next
    .Range("g2").CopyFromRecordset adoRS
    
End With
adoRS.Close: Set adoRS = Nothing: cnn.Close: Set cnn = Nothing

End Sub

Quá hay, đang tìm cái vụ select lồng mà cứ báo lỗi mấy cái dấu ( ...
Anh Sealand!
Theo em thì nếu vận dụng cho kết kết quả chính xác và nhất là dữ liệu có thể lơn > 50.000 rows thì cũng nên vận dụng nhiều cách. Trong đó ADO cũng là 1 lựa chọn tối ưu. Chớ còn # 100 dòng thì dùng tay cũng ra, cũng lắm là in công nợ.

Ba Tê · 27/9/12

concogia đã viết:
Hihi, hoan hô anh Ba Tê đã cho ra một kết quả....trật lấc
90% anh Ba Tê cóc có làm kế toán được
Bài đó như thế này nè
1)- Những hóa đơn nào có Loại (cột B) là 1, 3 & 4 mới tính ( 2 & 5 "nô tế bồ")
2)- Những hóa đơn nào mà trùng về "Ngày" (cột F) và "Mã số" (cột H) và tổng số tiền (cột N) của chúng nó phải lớn hơn 20 triệu thì liệt kê chúng nó ra
3)- Trong bảng Ba Tê nhìn thấy có hóa đơn dưới 20 triệu vẫn liệt kê vì ........nó thỏa điều kiện
Thí dụ: Hoá đơn số 579 Ngày 01/01/2012 Mã số 305.216.236 số tiền 19.652.500 ( nhỏ hơn 20 triệu, hihi) trùng Ngày & Mã số với số hóa đơn 580 có số tiền là 9.652.500. Số tiền của 2 em này cộng lại lớn hơn 20 triệu ==> thỏa ==> liệt kê 2 em đó ra
Tương tự, số hóa đơn 1158 trùng với 1168; 22740 trùng với 23234......
Híc

Hổng hiểu nên làm "trật lấc". Làm lại coi sao, dong luôn mắc cỡ chết!

PHP:

Public Sub GPE()
Dim Rng(), Arr(), I As Long, K As Long, Dic As Object, Tem As Variant, Ma As String
Set Dic = CreateObject("Scripting.Dictionary")
    Rng = Range([B18], [B65000].End(xlUp)).Resize(, 13).Value
ReDim Arr(1 To UBound(Rng, 1), 1 To 4)
    For I = 1 To UBound(Rng, 1)
            Tem = Rng(I, 1)
        If Tem <> "" Then
            If Tem <> 2 And Tem <> 5 Then
                Ma = Rng(I, 5) & Rng(I, 7)
                If Not Dic.exists(Ma) Then
                    Dic.Add Ma, Rng(I, 13)
                Else
                    Dic.Item(Ma) = Dic.Item(Ma) + Rng(I, 13)
                End If
            End If
        End If
    Next I
    For I = 1 To UBound(Rng, 1)
        If Rng(I, 1) <> 2 And Rng(I, 1) <> 5 Then
            Ma = Rng(I, 5) & Rng(I, 7)
            If Dic.Item(Ma) >= 20000000 Then
                K = K + 1
                Arr(K, 1) = Rng(I, 4): Arr(K, 2) = Rng(I, 5)
                Arr(K, 3) = Rng(I, 7): Arr(K, 4) = Rng(I, 13)
            End If
        End If
    Next I
    [R18:U10000].ClearContents
    [R18].Resize(K, 4).Value = Arr
Set Dic = Nothing
End Sub

Hai Lúa Miền Tây · 27/9/12

ThuNghi đã viết:
Quá hay, đang tìm cái vụ select lồng mà cứ báo lỗi mấy cái dấu ( ...
Anh Sealand!
Theo em thì nếu vận dụng cho kết kết quả chính xác và nhất là dữ liệu có thể lơn > 50.000 rows thì cũng nên vận dụng nhiều cách. Trong đó ADO cũng là 1 lựa chọn tối ưu. Chớ còn # 100 dòng thì dùng tay cũng ra, cũng lắm là in công nợ.

Hong biết anh ThuNghi có áp dụng gì được cho bài toán này không?

hoanglocphat · 23/2/13

Ba Tê đã viết:

Hổng hiểu nên làm "trật lấc". Làm lại coi sao, dong luôn mắc cỡ chết!

PHP:

Public Sub GPE()
Dim Rng(), Arr(), I As Long, K As Long, Dic As Object, Tem As Variant, Ma As String
Set Dic = CreateObject("Scripting.Dictionary")
    Rng = Range([B18], [B65000].End(xlUp)).Resize(, 13).Value
ReDim Arr(1 To UBound(Rng, 1), 1 To 4)
    For I = 1 To UBound(Rng, 1)
            Tem = Rng(I, 1)
        If Tem <> "" Then
            If Tem <> 2 And Tem <> 5 Then
                Ma = Rng(I, 5) & Rng(I, 7)
                If Not Dic.exists(Ma) Then
                    Dic.Add Ma, Rng(I, 13)
                Else
                    Dic.Item(Ma) = Dic.Item(Ma) + Rng(I, 13)
                End If
            End If
        End If
    Next I
    For I = 1 To UBound(Rng, 1)
        If Rng(I, 1) <> 2 And Rng(I, 1) <> 5 Then
            Ma = Rng(I, 5) & Rng(I, 7)
            If Dic.Item(Ma) >= 20000000 Then
                K = K + 1
                Arr(K, 1) = Rng(I, 4): Arr(K, 2) = Rng(I, 5)
                Arr(K, 3) = Rng(I, 7): Arr(K, 4) = Rng(I, 13)
            End If
        End If
    Next I
    [R18:U10000].ClearContents
    [R18].Resize(K, 4).Value = Arr
Set Dic = Nothing
End Sub

Các bạn cho hỏi, trong trường hợp không có Record nào thỏa mãn điều kiện thì khi chạy code thì báo lỗi
"Application - defined or object - defined error"
Lỗi ở dòng
[R18].Resize(K, 4).Value = Arr
Vậy cho hỏi cách sửa code để không bị báo lỗi. Xin cảm ơn!

ndu96081631 · 23/2/13

hoanglocphat đã viết:
Các bạn cho hỏi, trong trường hợp không có Record nào thỏa mãn điều kiện thì khi chạy code thì báo lỗi
"Application - defined or object - defined error"
Lỗi ở dòng
[R18].Resize(K, 4).Value = Arr
Vậy cho hỏi cách sửa code để không bị báo lỗi. Xin cảm ơn!

Nếu không tìm thấy thì k sẽ = 0. Vậy:
If K Then [R18].Resize(K, 4).Value = Arr
Xong!

Giúp code Lọc cùng ngày và cùng mã và một số điều kiện khác! (1 người xem)

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

Busy

File đính kèm

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

Busy

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

Busy

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

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

Busy

Huyền thoại GPE

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

Busy

Gội rồi mới Cạo

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

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

Busy

Cạo Rồi Khỏi Gội

Gội rồi mới Cạo

Cạo Rồi Khỏi Gội

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

File đính kèm

❆❆❆❆❆❆❆❆

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

File đính kèm

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

Busy

❆❆❆❆❆❆❆❆

File đính kèm

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

Cạo Rồi Khỏi Gội

File đính kèm

❆❆❆❆❆❆❆❆

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

Huyền thoại GPE

Thời gian đếm ngược.