Lọc dữ liệu, chuyển hàng thành cột, thu gọn

[aviaiva]

nhờ các bác pro giải hộ em bài toán excel trên bằng VBA.
cảm ơn các bác nhiều

 

[ndu96081631]

nhờ các bác pro giải hộ em bài toán excel trên bằng VBA.
cảm ơn các bác nhiều

Cái này chắc là ngon lành:

Sub Transfer(Src1 As Range, Src2 As Range, Target As Range)
  Dim Arr(1 To 10000, 1 To 200), Temp1, Temp2, Tmp1, Tmp2, Func As WorksheetFunction
  Dim i As Long, n As Long, m As Long, k As Long, iMax As Long
  Temp1 = Src1.Value
  Temp2 = Src2.Value
  Set Func = Application.WorksheetFunction
  With CreateObject("Scripting.Dictionary")
    For i = 1 To UBound(Temp1)
      If Temp1(i, 1) <> "" Then
        Tmp1 = Temp1(i, 1): Tmp2 = Temp2(i, 1)
        If Not .Exists(Tmp1) Then
          n = n + 1
          .Add Tmp1, 2
          Arr(n, 1) = Tmp1: Arr(n, 2) = Tmp2
        Else
          m = Func.Match(Tmp1, .Keys, 0)
          .Item(Tmp1) = .Item(Tmp1) + 1
          Arr(m, .Item(Tmp1)) = Tmp2
        End If
        If iMax < .Item(Tmp1) Then iMax = .Item(Tmp1)
      End If
    Next
  End With
  Target.Resize(n, iMax) = Arr
End Sub

Sub chạy chính:

Sub Main()
  Dim Src1 As Range, Src2 As Range, Target As Range
  With Sheet1.Range("A1:A1000")
    Set Src2 = .Resize(, 1).Offset(, 0)
    Set Src1 = .Resize(, 1).Offset(, 1)
  End With
  Set Target = Sheet1.Range("D10")
  Transfer Src1, Src2, Target
End Sub

 

[concogia]

nhờ các bác pro giải hộ em bài toán excel trên bằng VBA.
cảm ơn các bác nhiều

Cũng có thể dùng For...

Private Sub CommandButton1_Click()
Dim vung, cll, kqua As Range, i  As Long
 Range("d10:h1000").ClearContents
    Set vung = Range([b1], [b1000].End(xlUp))
      vung.AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("d10"), Unique:=True
        Set kqua = Range([d10], [d1000].End(xlUp))
          For i = 1 To kqua.Rows.Count
            For Each cll In vung
                If cll = kqua(i) Then Range("p" & kqua(i).Row).End(xlToLeft).Offset(0, 1) = cll.Offset(0, -1)
            Next
          Next i
End Sub

Tạo nút rồi gán code này vào nhé bạn

 

[huuthang_bd]

Có thể dùng Sort, AdvanFilter để giảm bớt số lần duyệt của vòng lặp. Số mã trùng càng nhiều thì tốc độ càng nhanh.

Sub Test()
Dim Rng As Range, Cll As Range, CountOfValue As Long
Set Rng = Range([A1], [B65536].End(xlUp))
Set WF = Application.WorksheetFunction
    Rng.Sort [B1], 1, , , , , , xlYes
    Set Rng = Rng.Offset(, 1).Resize(, 1)
    Rng.AdvancedFilter 2, , [C1], True
        For Each Cll In Range([C1], [C65536].End(xlUp))
            CountOfValue = WF.CountIf(Rng, Cll.Value)
            Cll.Offset(, 1).Resize(, CountOfValue).Value = WF.Transpose(Rng(WF.Match(Cll.Value, Rng, 0)).Offset(, -1).Resize(CountOfValue))
        Next
End Sub

 

[tutientrung]

Mình cũng có 1 vấn đề như bài của tác giả hỏi ,nhưng là ngược lại :tức là cột B và A sẽ đổi vị trí cho nhau và kết quả cũng ra như vậy .Mong các bạn chỉ mình cách chỉnh code cho phù hợp(hay viết code mới) .Cám ơn các bạn nhiều lắm lắm .

 

[ndu96081631]

Mình cũng có 1 vấn đề như bài của tác giả hỏi ,nhưng là ngược lại :tức là cột B và A sẽ đổi vị trí cho nhau và kết quả cũng ra như vậy .Mong các bạn chỉ mình cách chỉnh code cho phù hợp(hay viết code mới) .Cám ơn các bạn nhiều lắm lắm .

Code của tôi tổng quát rồi bạn à! Cột nào nằm đâu cũng chơi tuốt
Ví dụ với bài trên, nếu hoán đổi vị trí 2 cột A, B thì code sẽ vầy:

Sub Main()
  Dim Src1 As Range, Src2 As Range, Target As Range
  With Sheet1.Range("A1:A1000")
    Set Src1 = .Resize(, 1).Offset(, 0)
    Set Src2 = .Resize(, 1).Offset(, 1)
  End With
  Set Target = Sheet1.Range("D10")
  Transfer Src1, Src2, Target
End Sub

Vậy thôi
--------------
Dám cá với các bạn không có code nào có thể qua mặt được về tốc độ so với code này, kể cả Advanced Filter
Thí nghiệm dữ liệu 20.000 dòng và số phần tử trùng là không nhiều sẽ biết liền

 

[tutientrung]

Đã kiểm nghiệm và thấy nhanh thật.Dữ liệu của mình 17.000 dòng .Chạy phà phà luôn .Cho nên bấm cám ơn không thì thấy chưa đủ nên viết vài lời cảm tạ sâu sắc đến các bạn đã tạo ra chủ đề này .Đặc biệt cảm tạ NDU đã phản hồi nhanh và rất thú vị với cách khặng định của mình .Ẹc Ẹc...

 

[ndu96081631]

Đã kiểm nghiệm và thấy nhanh thật.Dữ liệu của mình 17.000 dòng .Chạy phà phà luôn .Cho nên bấm cám ơn không thì thấy chưa đủ nên viết vài lời cảm tạ sâu sắc đến các bạn đã tạo ra chủ đề này .Đặc biệt cảm tạ NDU đã phản hồi nhanh và rất thú vị với cách khặng định của mình .Ẹc Ẹc...

Lưu ý trong code của tôi chỉ mới thiết kế mảng 10000 dòng, 200 cột thôi nha
Nếu dữ liệu của bạn 17.000 dòng thì sửa chổ này:
Dim Arr(1 To 10000, 1 To 200)
Thành:
Dim Arr(1 To 20000, 1 To 200)
hoặc sửa luôn thành:
Dim Arr(1 To 60000, 1 To 200)
cho thoải mái
Nói chung là mảng này bạn muốn mở rộng bao nhiêu tùy ý (miễn nhỏ hơn số dòng, cột của bảng tính) nó vẫn chạy tốc độ ào ào