Thống kê (đếm) số người có cùng mã phiếu và chỉ ra năm sinh!

[nguyen6571gpex]

Chào cả nhà GPE!
Mình nhờ các bạn giúp thống kê số người nhận chung một mã phiếu và copy năm sinh những người đó vào cùng dòng theo thứ tự từ nhỏ đến lớn. Cụ thể trong file đính kèm. Trân trọng cảm ơn!

 

[nguyen6571gpex]

Không bạn nào giúp mình với nhỉ. Để thống kê số người nhận cùng mã thì dùng công thức mình làm được nhưng lọc lấy năm sinh thì chịu, mà VBA thì "mù". Các bạn giúp mình với!

 

[PacificPR]

Không bạn nào giúp mình với nhỉ. Để thống kê số người nhận cùng mã thì dùng công thức mình làm được nhưng lọc lấy năm sinh thì chịu, mà VBA thì "mù". Các bạn giúp mình với!

Bạn xem thử file này xem.

 

[nguyen6571gpex]

Rất cảm ơn bạn PacificPR đã giúp mình! Bạn kiểm tra giúp mình xem: Khi mình coppy dữ liệu vào thì code chạy báo lỗi tai module2 tại vị trí dArr(K, j + 3) = Tmp(j), mà mình thấy dữ liệu ở sheet "Danh sách phiếu điều tra có sự thay đổi tại i4:J9 bạn xem thế nào. Cảm ơn bạn!

 

[PacificPR]

Rất cảm ơn bạn PacificPR đã giúp mình! Bạn kiểm tra giúp mình xem: Khi mình coppy dữ liệu vào thì code chạy báo lỗi tai module2 tại vị trí dArr(K, j + 3) = Tmp(j), mà mình thấy dữ liệu ở sheet "Danh sách phiếu điều tra có sự thay đổi tại i4:J9 bạn xem thế nào. Cảm ơn bạn!

Bạn copy như thế nào mà lỗi vậy. Mình chạy thấy bình thường. Bạn đính kèm cái file lỗi nên mình xem thử
P/S: Nếu có năm sinh giống nhau trong cùng 1 mã phiếu có lọc trùng không hả bạn. Úi mà cái Code này chậm lắm. Dữ liệu 20.000 dòng có hiện tượng quay quay rồi

 

[HieuCD]

Chào cả nhà GPE!
Mình nhờ các bạn giúp thống kê số người nhận chung một mã phiếu và copy năm sinh những người đó vào cùng dòng theo thứ tự từ nhỏ đến lớn. Cụ thể trong file đính kèm. Trân trọng cảm ơn!

Thử code

Public Sub GPE()
Dim Arr(), dArr(), i As Long, k As Long, jMax As Long
With Sheet2
  Arr = .Range("B4:D4" & i).Value
  Range("B4").CurrentRegion.Clear
  .Range("B4:D4" & i) = Arr
 
  i = Sheet1.Range("G" & Rows.Count).End(xlUp).Row
  Arr = Sheet1.Range("G5:G" & i).Value
  .Range("M2").Resize(UBound(Arr)) = Arr
  Arr = Sheet1.Range("O5:O" & i).Value
  .Range("L2").Resize(UBound(Arr)) = Arr
 
  .Range("L2:M2").Resize(UBound(Arr)).Sort .Range("L2"), 1, .Range("M2"), , 1, Header:=xlNo
  dArr = .Range("L1:M1").Resize(UBound(Arr) + 1).Value
  .Range("L2:M2").Resize(UBound(Arr)).ClearContents

  ReDim Arr(1 To UBound(dArr, 1) - 1, 1 To 300) 'Neu khong du thi tang so 300 len
  jMax = 3
  For i = 2 To UBound(dArr, 1)
    If dArr(i, 1) <> dArr(i - 1, 1) Then
      k = k + 1
      Arr(k, 1) = dArr(i, 1)
      Arr(k, 2) = 1
      Arr(k, 3) = dArr(i, 2)
    Else
      Arr(k, 2) = Arr(k, 2) + 1
      Arr(k, Arr(k, 2) + 2) = dArr(i, 2)
      If jMax < Arr(k, 2) + 2 Then jMax = Arr(k, 2) + 2
    End If
  Next i
 
  .Range("B5").Resize(k, jMax) = Arr
  Range("B4").CurrentRegion.Borders.LineStyle = 1
End With
End Sub

 

[nguyen6571gpex]

Bạn copy như thế nào mà lỗi vậy. Mình chạy thấy bình thường. Bạn đính kèm cái file lỗi nên mình xem thử
P/S: Nếu có năm sinh giống nhau trong cùng 1 mã phiếu có lọc trùng không hả bạn. Úi mà cái Code này chậm lắm. Dữ liệu 20.000 dòng có hiện tượng quay quay rồi

Cảm ơn bạn! mình thử code này thì chạy chậm thật và năm sinh trùng nhau đã bị lọc trùng. Mình thấy code bạn HieuCD chạy tốt, bạn có thể cùng tham khảo. Một lần nữa cảm ơn bạn, chúc bạn một ngày vui!

 

[nguyen6571gpex]

Thử code

Public Sub GPE()
Dim Arr(), dArr(), i As Long, k As Long, jMax As Long
With Sheet2
  Arr = .Range("B4:D4" & i).Value
  Range("B4").CurrentRegion.Clear
  .Range("B4:D4" & i) = Arr
 
  i = Sheet1.Range("G" & Rows.Count).End(xlUp).Row
  Arr = Sheet1.Range("G5:G" & i).Value
  .Range("M2").Resize(UBound(Arr)) = Arr
  Arr = Sheet1.Range("O5:O" & i).Value
  .Range("L2").Resize(UBound(Arr)) = Arr
 
  .Range("L2:M2").Resize(UBound(Arr)).Sort .Range("L2"), 1, .Range("M2"), , 1, Header:=xlNo
  dArr = .Range("L1:M1").Resize(UBound(Arr) + 1).Value
  .Range("L2:M2").Resize(UBound(Arr)).ClearContents

  ReDim Arr(1 To UBound(dArr, 1) - 1, 1 To 300) 'Neu khong du thi tang so 300 len
  jMax = 3
  For i = 2 To UBound(dArr, 1)
    If dArr(i, 1) <> dArr(i - 1, 1) Then
      k = k + 1
      Arr(k, 1) = dArr(i, 1)
      Arr(k, 2) = 1
      Arr(k, 3) = dArr(i, 2)
    Else
      Arr(k, 2) = Arr(k, 2) + 1
      Arr(k, Arr(k, 2) + 2) = dArr(i, 2)
      If jMax < Arr(k, 2) + 2 Then jMax = Arr(k, 2) + 2
    End If
  Next i
 
  .Range("B5").Resize(k, jMax) = Arr
  Range("B4").CurrentRegion.Borders.LineStyle = 1
End With
End Sub

Cảm ơn bạn đã nhiệt tình giúp đỡ! Mình đã test và thấy code chạy nhanh, tốt. Một lần nữa cảm ơn và chúc bạn một ngày vui! Nếu có vấn đề gì mình nhờ các bạn giúp tiếp. Trân trọng!