Hỏi về trích lọc dữ liệu duy nhất từ một mảng (3 người xem)

  • Thread starter Thread starter khamha
  • Ngày gửi Ngày gửi
Liên hệ QC

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

Đang trực tuyến: 1 (Thành viên: 0, Khách: 1)
khamha

khamha

Không có việc gì khó...
Tham gia
4/6/10
Bài viết
662
Được thích
846
Nghề nghiệp
CNVC Laos
Chào cả nhà, Như tiêu đề...mình muốn lọc dữ liệu từ một mảng “A5:J” (Tương đương với 10 vùng nằm sát nhau)
* Điều kiện:
1, Lọc lấy dữ liệu duy nhất từ trong mảng.
2, Lọc bằng VBA
3, Dữ liệu sau khi lọc hiển thị bắt đầu tại cột “K5”
Cảm ơn.
 
Lần chỉnh sửa cuối:
khamha đã viết:
Chào cả nhà, Như tiêu đề...mình muốn lọc dữ liệu từ một mảng “A5:J” (Tương đương với 10 vùng nằm sát nhau)
* Điều kiện:
1, Lọc lấy dữ liệu duy nhất từ trong mảng.
2, Lọc bằng VBA
3, Dữ liệu sau khi lọc hiển thị bắt đầu tại cột “K5”
Cảm ơn.
Nhấp chuột vào đây để mở rộng...

Không có file và yêu cầu rõ ràng, chẳng hiểu gì cả.
 
khamha đã viết:
Chào cả nhà, Như tiêu đề...mình muốn lọc dữ liệu từ một mảng “A5:J” (Tương đương với 10 vùng nằm sát nhau)
* Điều kiện:
1, Lọc lấy dữ liệu duy nhất từ trong mảng.
2, Lọc bằng VBA
3, Dữ liệu sau khi lọc hiển thị bắt đầu tại cột “K5”
Cảm ơn.
Nhấp chuột vào đây để mở rộng...
PHP: 
Sub loc_kieu_thay_boi_mu()
[K5].Resize(1000, 10).ClearContents
[A5].Resize(10000, 10).AdvancedFilter 2, , [K5], 2
End Sub
 
"1, Lọc lấy dữ liệu duy nhất từ trong mảng." ---> Cái này em chưa hiểu, tiêu chí???
 
PhanTuHuong đã viết:
"1, Lọc lấy dữ liệu duy nhất từ trong mảng." ---> Cái này em chưa hiểu, tiêu chí???
Nhấp chuột vào đây để mở rộng...
Mọi người thông cảm nhé...Chung quy chỉ do cái thằng nhà mạng UNITEL (ko biết là do nó hay do máy mình nữa) mà tối qua up File lên ko được ,mà File có nhiều nhặn gì đâu...sau khi nén còn có 8KB mà nó cứ tụt lên tụt xuống ko thể up nổi...̣đúng là ko biết bó tay chấm cái gì nữa.
Các bạn xem File đính kèm và giúp mình nhé.
 

File đính kèm

khamha đã viết:
Mọi người thông cảm nhé...Chung quy chỉ do cái thằng nhà mạng UNITEL (ko biết là do nó hay do máy mình nữa) mà tối qua up File lên ko được ,mà File có nhiều nhặn gì đâu...sau khi nén còn có 8KB mà nó cứ tụt lên tụt xuống ko thể up nổi...̣đúng là ko biết bó tay chấm cái gì nữa.
Các bạn xem File đính kèm và giúp mình nhé.
Nhấp chuột vào đây để mở rộng...

Dùng cái này:
Mã: 
Function UniqueList(ParamArray sArray())
  Dim Item, tmpArr, SubArr, tmp
  'On Error Resume Next
  With CreateObject("Scripting.Dictionary")
    For Each SubArr In sArray
      tmpArr = SubArr
      If Not IsArray(tmpArr) Then tmpArr = Array(tmpArr)
      For Each Item In tmpArr
        tmp = CStr(Item)
        If Len(tmp) Then
          If Not .Exists(tmp) Then .Add tmp, ""
        End If
      Next
    Next
    If .Count Then UniqueList = .Keys
  End With
End Function
Sub Main()
  Dim Arr
  With Sheet1
    .Range("K5:K10000").ClearContents
    Arr = UniqueList(.Range("A5:J10000"))
    If IsArray(Arr) Then .Range("K5").Resize(UBound(Arr) + 1).Value = WorksheetFunction.Transpose(Arr)
  End With
End Sub
Chạy Sub Main sẽ có kết quả
 
Lần chỉnh sửa cuối:
khamha đã viết:
Mọi người thông cảm nhé...Chung quy chỉ do cái thằng nhà mạng UNITEL (ko biết là do nó hay do máy mình nữa) mà tối qua up File lên ko được ,mà File có nhiều nhặn gì đâu...sau khi nén còn có 8KB mà nó cứ tụt lên tụt xuống ko thể up nổi...̣đúng là ko biết bó tay chấm cái gì nữa.
Các bạn xem File đính kèm và giúp mình nhé.
Nhấp chuột vào đây để mở rộng...
Anh test thử code này xem sao nhé
[GPECODE=vb]
Sub Loc()
Dim Arr(), Tmp(), ArrKq(1 To 10000, 1 To 1)
Dim i&, j&, k&
Arr = Sheet1.Range("A4").CurrentRegion.Value
With CreateObject("Scripting.Dictionary")
For i = 2 To UBound(Arr)
For j = 1 To UBound(Arr, 2)-1
If Arr(i, j) <> "" And Not .Exists(Arr(i, j)) Then
k = k + 1
.Add Arr(i, j), k
ArrKq(k, 1) = Arr(i, j)
End If
Next j
Next
End With
Sheet1.Range("K5").Resize(k).Value = ArrKq
End Sub[/GPECODE]
 
Lần chỉnh sửa cuối:
Cách giải quyết của ndu và viehoai đều OK ,Tuy:
1, Của bạn ndu: Code dài ,Lọc loại bỏ các dòng trống.
2, Của bạn viehoai: Code ngắn ,khi lọc lại ko loại bỏ dòng trống "chỉ lọc dữ liệu có liên tục"
 
khamha đã viết:
Cách giải quyết của ndu và viehoai đều OK ,Tuy:
1, Của bạn ndu: Code dài ,Lọc loại bỏ các dòng trống.
2, Của bạn viehoai: Code ngắn ,khi lọc lại ko loại bỏ dòng trống "chỉ lọc dữ liệu có liên tục"
Nhấp chuột vào đây để mở rộng...
Code tuy dài nhưng cái hàm UniqueList ấy chỉ viết 1 lần rồi xài mãi mãi. Mai này nếu có áp dụng qua các bài toán khác, cùng lắm bạn chỉ sửa Sub Main là đủ
Ngoài ra cũng xin nói thêm: Hàm UniqueList này không chỉ hoạt động trên Range mà còn làm việc được với mảng (lọc duy nhất trong ListBox, ComboBox chẳng hạn)
 
khamha đã viết:
Cách giải quyết của ndu và viehoai đều OK ,Tuy:
1, Của bạn ndu: Code dài ,Lọc loại bỏ các dòng trống.
2, Của bạn viehoai: Code ngắn ,khi lọc lại ko loại bỏ dòng trống "chỉ lọc dữ liệu có liên tục"
Nhấp chuột vào đây để mở rộng...
Vầy cũng ngắn nè.
PHP: 
Sub loc()
Dim data(), item
data = [A5].Resize(65000, 10).Value
With CreateObject("scripting.dictionary")
   For Each item In data
      If item <> "" Then
         If Not .exists(item) Then .Add item, ""
      End If
   Next
   [K5].Resize(.Count) = Application.Transpose(.keys)
End With
End Sub

PS: Theo kinh nghiệm thì chịu khó dùng 2 lần If, tránh dùng And thì tốc độ cải thiện đáng kể
 
Lần chỉnh sửa cuối:
ndu96081631 đã viết:
Dùng cái này:
Mã: 
Function UniqueList(ParamArray sArray())
  Dim Item, tmpArr, SubArr, tmp
  'On Error Resume Next
  With CreateObject("Scripting.Dictionary")
    For Each SubArr In sArray
      tmpArr = SubArr
      If Not IsArray(tmpArr) Then tmpArr = Array(tmpArr)
      For Each Item In tmpArr
        tmp = CStr(Item)
        If Len(tmp) Then
          If Not .Exists(tmp) Then .Add tmp, ""
        End If
      Next
    Next
    If .Count Then UniqueList = .Keys
  End With
End Function
Sub Main()
  Dim Arr
  With Sheet1
    .Range("K5:K10000").ClearContents
    Arr = UniqueList(.Range("A5:J10000"))
    If IsArray(Arr) Then .Range("K5").Resize(UBound(Arr) + 1).Value = WorksheetFunction.Transpose(Arr)
  End With
End Sub
Chạy Sub Main sẽ có kết quả
Nhấp chuột vào đây để mở rộng...
Chào các bạn, mình có 1 bài tương tự nên xin chen ngang 1 chút, nhờ tất cả các bạn giúp đỡ

1/ Tại trang "ThongKe" cell C5, sau khi mình chọn "Thang01" thì code sẽ lọc duy nhất của cột D của Sheet" Thang01", và code sẽ cho kết qủa bắt đầu từ cell E7 của sheet "ThongKe". Tương tự nếu chọn cell C5 cua sheet "ThongKe" là "Thang02" thì lọc của Sheet "Thang02"....
2/ Mình muốn chạy code bằng Sub Main như trên, Không chạy bằng sự kiện "Private Sub Worksheet_Change"
3/ Nếu có thể thì sắp xếp theo thứ tự từ nhỏ đến lớn ở cột E của sheet "ThongKe"
--------------
Chủ đề lọc duy nhất có nhiều trên diễn đàn nhưng mình cũng kg biếp áp dụng sao cho trường hợp của mình
Xin cảm ơn tất cả
 

File đính kèm

hoanglocphat đã viết:
Chào các bạn, mình có 1 bài tương tự nên xin chen ngang 1 chút, nhờ tất cả các bạn giúp đỡ

1/ Tại trang "ThongKe" cell C5, sau khi mình chọn "Thang01" thì code sẽ lọc duy nhất của cột D của Sheet" Thang01", và code sẽ cho kết qủa bắt đầu từ cell E7 của sheet "ThongKe". Tương tự nếu chọn cell C5 cua sheet "ThongKe" là "Thang02" thì lọc của Sheet "Thang02"....
2/ Mình muốn chạy code bằng Sub Main như trên, Không chạy bằng sự kiện "Private Sub Worksheet_Change"
3/ Nếu có thể thì sắp xếp theo thứ tự từ nhỏ đến lớn ở cột E của sheet "ThongKe"
--------------
Chủ đề lọc duy nhất có nhiều trên diễn đàn nhưng mình cũng kg biếp áp dụng sao cho trường hợp của mình
Xin cảm ơn tất cả
Nhấp chuột vào đây để mở rộng...
Thử cái này coi
PHP: 
Sub loc()
With Sheets([C5].Value)
   .[D7:D65536].AdvancedFilter 2, , [E6], 2
End With
End Sub
 
hoanglocphat đã viết:
Chào các bạn, mình có 1 bài tương tự nên xin chen ngang 1 chút, nhờ tất cả các bạn giúp đỡ

1/ Tại trang "ThongKe" cell C5, sau khi mình chọn "Thang01" thì code sẽ lọc duy nhất của cột D của Sheet" Thang01", và code sẽ cho kết qủa bắt đầu từ cell E7 của sheet "ThongKe". Tương tự nếu chọn cell C5 cua sheet "ThongKe" là "Thang02" thì lọc của Sheet "Thang02"....
2/ Mình muốn chạy code bằng Sub Main như trên, Không chạy bằng sự kiện "Private Sub Worksheet_Change"
3/ Nếu có thể thì sắp xếp theo thứ tự từ nhỏ đến lớn ở cột E của sheet "ThongKe"
--------------
Chủ đề lọc duy nhất có nhiều trên diễn đàn nhưng mình cũng kg biếp áp dụng sao cho trường hợp của mình
Xin cảm ơn tất cả
Nhấp chuột vào đây để mở rộng...

Sửa Sub Main thành vầy:
Mã: 
Sub Main()
  Dim Arr
  Dim wks As Worksheet, rng As Range
  On Error Resume Next
  With Worksheets("ThongKe")
    Set wks = Worksheets(.Range("C5").Value)
    Set rng = wks.Range("D8:D10000")
    .Range("E7:E10000").ClearContents
    Arr = UniqueList(rng)
    If IsArray(Arr) Then
      Arr = WorksheetFunction.Transpose(Arr)
      With .Range("E7").Resize(UBound(Arr))
        .Value = Arr
        .Sort .Cells(1, 1), 1, Header:=xlNo
      End With
    End If
  End With
End Sub
 
quanghai1969 đã viết:
Vầy cũng ngắn nè.
PHP: 
Sub loc()
Dim data(), item
data = [A5].Resize(65000, 10).Value
With CreateObject("scripting.dictionary")
   For Each item In data
      If item <> "" Then
         If Not .exists(item) Then .Add item, ""
      End If
   Next
   [K5].Resize(.Count) = Application.Transpose(.keys)
End With
End Sub

PS: Theo kinh nghiệm thì chịu khó dùng 2 lần If, tránh dùng And thì tốc độ cải thiện đáng kể
Nhấp chuột vào đây để mở rộng...

Mình sử dụng đoạn Code trên...và nhờ các bạn giúp thêm vấn đề tính tổng cho từng nội dung (Các bạn xem File đính kèm)
 

File đính kèm

khamha đã viết:
Mình sử dụng đoạn Code trên...và nhờ các bạn giúp thêm vấn đề tính tổng cho từng nội dung (Các bạn xem File đính kèm)
Nhấp chuột vào đây để mở rộng...
Thử với Sub này xem sao.
PHP: 
Public Sub GPE()
Dim Arr1(), Arr2(), Darr(), I As Long, J As Long, K As Long, Tem As String, Dic As Object
Set Dic = CreateObject("Scripting.Dictionary")
Arr1 = Range([A5], [A65000].End(xlUp)).Resize(, 12).Value
Arr2 = Range([A5], [A65000].End(xlUp)).Offset(, 12).Resize(, 12).Value
ReDim Darr(1 To UBound(Arr1, 1) * 12, 1 To 2)
For J = 1 To 12
    For I = 1 To UBound(Arr1, 1)
        If Arr1(I, J) <> "" Then
            Tem = Arr1(I, J)
            If Not Dic.Exists(Tem) Then
                K = K + 1
                Dic.Add (Tem), K
                Darr(K, 1) = Tem: Darr(K, 2) = Arr2(I, J)
            Else
                Darr(Dic.item(Tem), 2) = Darr(Dic.item(Tem), 2) + Arr2(I, J)
            End If
        End If
    Next I
Next J
[Y5:Z65000].ClearContents
If K Then [Y5].Resize(K, 2).Value = Darr
Set Dic = Nothing
End Sub
 
Lần chỉnh sửa cuối:
Ba Tê đã viết:
Thử với Sub này xem sao.
PHP: 
Public Sub GPE()
Dim Arr1(), Arr2(), Darr(), I As Long, J As Long, K As Long, Tem As String, Dic As Object
Set Dic = CreateObject("Scripting.Dictionary")
Arr1 = Range([A5], [A65000].End(xlUp)).Resize(, 12).Value
Arr2 = Range([A5], [A65000].End(xlUp)).Offset(, 12).Resize(, 12).Value
ReDim Darr(1 To UBound(Arr1, 1) * 12, 1 To 2)
For J = 1 To 12
    For I = 1 To UBound(Arr1, 1)
        If Arr1(I, J) <> "" Then
            Tem = Arr1(I, J)
            If Not Dic.Exists(Tem) Then
                K = K + 1
                Dic.Add (Tem), K
                Darr(K, 1) = Tem: Darr(K, 2) = Arr2(I, J)
            Else
                Darr(Dic.item(Tem), 2) = Darr(Dic.item(Tem), 2) + Arr2(I, J)
            End If
        End If
    Next I
Next J
[Y5:Z65000].ClearContents
If K Then [Y5].Resize(K, 2).Value = Darr
Set Dic = Nothing
End Sub
Nhấp chuột vào đây để mở rộng...

Cảm ơn bạn BaTê ,Code chuẩn...Nhưng mình lại quên là khi hoạt động thì ngoài loại bỏ dòng trống ra còn phải loại bỏ cá dấu chấm "." và phẩy "," nữa ,Bạn thông cảm...Và giúp mình nhé.
 
khamha đã viết:
Cảm ơn bạn BaTê ,Code chuẩn...Nhưng mình lại quên là khi hoạt động thì ngoài loại bỏ dòng trống ra còn phải loại bỏ cá dấu chấm "." và phẩy "," nữa ,Bạn thông cảm...Và giúp mình nhé.
Nhấp chuột vào đây để mở rộng...

Dấu chấm, phẩy ở đâu "Chời", Các mã a1, a2, fdfd ... gì đó của bạn ít nhất bao nhiêu ký tự? Bạn đưa dữ liệu "hơi thật" một chút xem.
Nếu các mã luôn từ 2 ký tự trở lên thì thằng nào chỉ có 1 ký tự không tính.
PHP: 
Public Sub GPE()
Dim Arr1(), Arr2(), Darr(), I As Long, J As Long, K As Long, Tem As String, Dic As Object
Set Dic = CreateObject("Scripting.Dictionary")
Arr1 = Range([A5], [A65000].End(xlUp)).Resize(, 12).Value
Arr2 = Range([A5], [A65000].End(xlUp)).Offset(, 12).Resize(, 12).Value
ReDim Darr(1 To UBound(Arr1, 1) * 12, 1 To 2)
For J = 1 To 12
    For I = 1 To UBound(Arr1, 1)
            Tem = Arr1(I, J)
        If Len(Arr1(I, J)) >= 2 Then
            If Not Dic.Exists(Tem) Then
                K = K + 1
                Dic.Add (Tem), K
                Darr(K, 1) = Tem: Darr(K, 2) = Arr2(I, J)
            Else
                Darr(Dic.item(Tem), 2) = Darr(Dic.item(Tem), 2) + Arr2(I, J)
            End If
        End If
    Next I
Next J
[Y5:Z65000].ClearContents
If K Then [Y5].Resize(K, 2).Value = Darr
Set Dic = Nothing
End Sub
 
Lần chỉnh sửa cuối:
Ba Tê đã viết:
Thử với Sub này xem sao.
PHP: 
Public Sub GPE()
Dim Arr1(), Arr2(), Darr(), I As Long, J As Long, K As Long, Tem As String, Dic As Object
Set Dic = CreateObject("Scripting.Dictionary")
Arr1 = Range([A5], [A65000].End(xlUp)).Resize(, 12).Value
Arr2 = Range([A5], [A65000].End(xlUp)).Offset(, 12).Resize(, 12).Value
ReDim Darr(1 To UBound(Arr1, 1) * 12, 1 To 2)
For J = 1 To 12
    For I = 1 To UBound(Arr1, 1)
        If Arr1(I, J) <> "" Then
            Tem = Arr1(I, J)
            If Not Dic.Exists(Tem) Then
                K = K + 1
                Dic.Add (Tem), K
                Darr(K, 1) = Tem: Darr(K, 2) = Arr2(I, J)
            Else
                Darr(Dic.item(Tem), 2) = Darr(Dic.item(Tem), 2) + Arr2(I, J)
            End If
        End If
    Next I
Next J
[Y5:Z65000].ClearContents
If K Then [Y5].Resize(K, 2).Value = Darr
Set Dic = Nothing
End Sub
Nhấp chuột vào đây để mở rộng...

Với code này, nếu xóa: A15:A17 và M15:M17 thì kết quả sẽ sai
Với dạng dữ liệu không có quy luật thế này, ta không nên End(xlUp) làm gì cho mất công ---> Cứ "phang" thằng từ A5 đến L20000 cho nó chắc
 
Lần chỉnh sửa cuối:
ndu96081631 đã viết:
Với code này, nếu xóa: A15:A17 và M15:M17 thì kết quả sẽ sai
Với dạng dữ liệu không có quy luật thế này, ta không nên End(xlUp) là gì cho mất công ---> Cứ "phang" thằng từ A5 đến L20000 cho nó chắc
Nhấp chuột vào đây để mở rộng...
Vậy phải xác định dòng cuối cùng có dữ liệu trong cột A:L
Hay cho nó "mút chỉ" luôn đến 65536?
 
Bạn phải đăng nhập hoặc đăng ký để trả lời bài viết tại đây.
Web KT

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

vsitcnh
Hỗ trợ công thức tính điểm dựa theo điều kiện.
Trả lời
18
Đọc
297
tle2003
T
D
Nhờ trợ giúp xác định thứ tự của các từ và cụm từ trong 1 chuỗi văn bản. (1 người xem)
Trả lời
5
Đọc
58
huhumalu
H
GPE-Trợ Lý
Đăng ký tham dự hội thảo tại Hà Nội: Power Query - Công cụ quản lý dữ liệu
    • Thích
    • Cảm ơn
    • Yêu thích
Trả lời
14
Đọc
2K
GPE-Trợ Lý
GPE-Trợ Lý
1
Vướng mắc về hàm lấy tên đăng nhập máy tính ạ (1 người xem)
Trả lời
17
Đọc
475
VetMini
V
GPE-Trợ Lý
[GPE] HỘI THẢO POWER QUERY – CÔNG CỤ QUẢN LÝ DỮ LIỆU HCM (2 người xem)
Trả lời
0
Đọc
77
GPE-Trợ Lý
GPE-Trợ Lý
G
Xin Code xóa Module.
Trả lời
10
Đọc
367
GCQ
G
ongke0711
  • Question Question
Tải hóa đơn điện tử (https://hoadondientu.gdt.gov.vn/) Excel Vba (1 người xem)
    • Thích
    • Yêu thích
    • Cảm ơn
16 17 18
Trả lời
348
Đọc
31K
ongke0711
ongke0711
D
  • Đã giải quyết
Quản lý email outlook qua VBA cần giúp đỡ (1 người xem)
2
Trả lời
23
Đọc
643
nguyendang95
N
G
Tách công thức ra khỏi chuỗi và tính kết quả? (1 người xem)
2
Trả lời
26
Đọc
2K
thuytrangbp28
T
thlpro
Cách lập Công thức tính số ngày nghỉ AL, ưu tiên tính 2024 trước rồi mới tính 2025 (1 người xem)
Trả lời
8
Đọc
158
bebo021999
B
N
Hàm tăng số đếm theo điều kiện
Trả lời
4
Đọc
79
bebo021999
B
M
Xin giúp đỡ làm công thức điều kiện
    • Yêu thích
Trả lời
3
Đọc
164
tayGa
T
N
Một ví dụ về XLL add-in: Tương tác với Google Gemini dưới dạng công thức bảng tính
    • Thích
Trả lời
2
Đọc
232
nguyendang95
N
K
  • Question Question
nhờ ace giúp đỡ tự động filter và In hàng loạt từng mục trong piviot table
Trả lời
5
Đọc
188
DeTong
D
Trungvt3
Công thức trả về định dạng không như mong muốn và viết phân số trong 1 ô.
Trả lời
5
Đọc
125
VetMini
V
N
Khắc phục lỗi "The picture is too large and will be truncated"
Trả lời
10
Đọc
5K
tle2003
T
C
  • Question Question
Xin hỏi Cách viết chú thích trong vba hiển thị tiếng việt
Trả lời
4
Đọc
199
ongke0711
ongke0711
B
Xin giải pháp chống sửa, xóa dữ liệu đã nhập vào từ ngày hôm trước. (1 người xem)
    • Thích
2
Trả lời
28
Đọc
7K
Hoàng Tuấn 868
H
00029591
Cần hỗ trợ công thức tổng hợp dữ liệu không cần cột phụ Vlookup
Trả lời
3
Đọc
181
tle2003
T
S
Mở 2 cửa sổ riêng biệt
2
Trả lời
30
Đọc
23K
sakuraluu
S
Xem thêm…

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

Đếm ngược thời gian

000
Ngày
00
Giờ
00
phút
00
giây
TALK SHOW: CÙNG NHẢY LAM BA ĐA VỚI HÀM LAMBDA (λ) EXCEL 365
Back
Top Bottom