Các câu hỏi về lọc ra danh sách duy nhất (loại bỏ dữ liệu trùng) (2 người xem)

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)
thanhthat đã viết:
Mình Uolad file rồi nhờ Bạn giúp với !
Nhấp chuột vào đây để mở rộng...
file đâu có khác gì file trước
Mã: 
Public Sub GPE()
  Dim Sh As Worksheet
  Dim dArr, Arr, key As Variant
  Dim i, k, lRow As Long
  Dim ShName, Col As String
  On Error Resume Next
  Col = InputBox("Nhap Ky Tu Cot muon tim, nhu A, B, C ... ")
Trolai:
  i = Range(Col & "1").Row
  If Err.Number Then
    Err.Clear
    Col = InputBox("Nhap sai, Nhap lai Ky Tu Cot muon tim, nhu A, B, C ... ")
    GoTo Trolai
  End If
  Col = UCase(Col)
  With CreateObject("Scripting.Dictionary")
    For Each Sh In Worksheets
      ShName = Sh.Name
      If ShName <> "Sheet1" Then
        lRow = Sh.Range(Col & Rows.Count).End(xlUp).Row
        If lRow = 1 Then lRow = 2
        dArr = Sh.Range(Col & 1).Resize(lRow).Value
        For i = 1 To UBound(dArr)
          key = dArr(i, 1)
          If key <> "" Then
            If Not .exists(key) Then
              .Add key, Array(ShName, Col & i)
            Else
              If IsArray(.Item(key)) Then .Item(key) = 1
            End If
          End If
        Next i
      End If
    Next Sh
    ReDim Arr(1 To .Count, 1 To 3)
    For i = 0 To .Count - 1
      dArr = .items()(i)
      If IsArray(dArr) Then
        k = k + 1
        Arr(k, 1) = dArr(0): Arr(k, 2) = dArr(1): Arr(k, 3) = .keys()(i)
      End If
    Next i
  End With
  With Sheet1
    .Range("A2", .Range("C" & .Range("A2").End(xlDown).Row)).ClearContents
    .Range("A2").Resize(k, 3) = Arr
  End With
End Sub
 

File đính kèm

HieuCD đã viết:
file đâu có khác gì file trước
Mã: 
Public Sub GPE()
  Dim Sh As Worksheet
  Dim dArr, Arr, key As Variant
  Dim i, k, lRow As Long
  Dim ShName, Col As String
  On Error Resume Next
  Col = InputBox("Nhap Ky Tu Cot muon tim, nhu A, B, C ... ")
Trolai:
  i = Range(Col & "1").Row
  If Err.Number Then
    Err.Clear
    Col = InputBox("Nhap sai, Nhap lai Ky Tu Cot muon tim, nhu A, B, C ... ")
    GoTo Trolai
  End If
  Col = UCase(Col)
  With CreateObject("Scripting.Dictionary")
    For Each Sh In Worksheets
      ShName = Sh.Name
      If ShName <> "Sheet1" Then
        lRow = Sh.Range(Col & Rows.Count).End(xlUp).Row
        If lRow = 1 Then lRow = 2
        dArr = Sh.Range(Col & 1).Resize(lRow).Value
        For i = 1 To UBound(dArr)
          key = dArr(i, 1)
          If key <> "" Then
            If Not .exists(key) Then
              .Add key, Array(ShName, Col & i)
            Else
              If IsArray(.Item(key)) Then .Item(key) = 1
            End If
          End If
        Next i
      End If
    Next Sh
    ReDim Arr(1 To .Count, 1 To 3)
    For i = 0 To .Count - 1
      dArr = .items()(i)
      If IsArray(dArr) Then
        k = k + 1
        Arr(k, 1) = dArr(0): Arr(k, 2) = dArr(1): Arr(k, 3) = .keys()(i)
      End If
    Next i
  End With
  With Sheet1
    .Range("A2", .Range("C" & .Range("A2").End(xlDown).Row)).ClearContents
    .Range("A2").Resize(k, 3) = Arr
  End With
End Sub
Nhấp chuột vào đây để mở rộng...
Đúng vậy, Em chỉ muốn tìm trên cột theo ý mình. Ok rồi Anh ạ!
Cám ơn Anh !
 
thanhthat đã viết:
Đúng vậy, Em chỉ muốn tìm trên cột theo ý mình. Ok rồi Anh ạ!
Cám ơn Anh !
Nhấp chuột vào đây để mở rộng...
Có một yêu cầu nhỏ nhờ Bạn giúp mình: Bạn chỉnh code khong phân biệt chữ Hoa chữ thường mình với như file mình Up lại.
Các AC sữa code giúp mình đang cần !!!
Cám ơn !
 

File đính kèm

Lần chỉnh sửa cuối:
HieuCD đã viết:
file đâu có khác gì file trước
Mã: 
Public Sub GPE()
  Dim Sh As Worksheet
  Dim dArr, Arr, key As Variant
  Dim i, k, lRow As Long
  Dim ShName, Col As String
  On Error Resume Next
  Col = InputBox("Nhap Ky Tu Cot muon tim, nhu A, B, C ... ")
Trolai:
  i = Range(Col & "1").Row
  If Err.Number Then
    Err.Clear
    Col = InputBox("Nhap sai, Nhap lai Ky Tu Cot muon tim, nhu A, B, C ... ")
    GoTo Trolai
  End If
  Col = UCase(Col)
  With CreateObject("Scripting.Dictionary")
    For Each Sh In Worksheets
      ShName = Sh.Name
      If ShName <> "Sheet1" Then
        lRow = Sh.Range(Col & Rows.Count).End(xlUp).Row
        If lRow = 1 Then lRow = 2
        dArr = Sh.Range(Col & 1).Resize(lRow).Value
        For i = 1 To UBound(dArr)
          key = dArr(i, 1)
          If key <> "" Then
            If Not .exists(key) Then
              .Add key, Array(ShName, Col & i)
            Else
              If IsArray(.Item(key)) Then .Item(key) = 1
            End If
          End If
        Next i
      End If
    Next Sh
    ReDim Arr(1 To .Count, 1 To 3)
    For i = 0 To .Count - 1
      dArr = .items()(i)
      If IsArray(dArr) Then
        k = k + 1
        Arr(k, 1) = dArr(0): Arr(k, 2) = dArr(1): Arr(k, 3) = .keys()(i)
      End If
    Next i
  End With
  With Sheet1
    .Range("A2", .Range("C" & .Range("A2").End(xlDown).Row)).ClearContents
    .Range("A2").Resize(k, 3) = Arr
  End With
End Sub
Nhấp chuột vào đây để mở rộng...
Anh HiueCD chỉnh lại code mà không phân biệt chữ hoa và chữ thường em với. Code về mảng em không rành lắm.
Cám ơn Anh !
 
thanhthat đã viết:
Anh HiueCD chỉnh lại code mà không phân biệt chữ hoa và chữ thường em với. Code về mảng em không rành lắm.
Cám ơn Anh !
Nhấp chuột vào đây để mở rộng...
Dùng hàm Ucase để chuyển key về chữ in
Mã: 
Public Sub GPE()
  Dim Sh As Worksheet
  Dim dArr, Arr, key As Variant
  Dim i, k, lRow As Long
  Dim ShName, Col As String
  On Error Resume Next
  Col = InputBox("Nhap Ky Tu Cot muon tim, nhu A, B, C ... ")
Trolai:
  i = Range(Col & "1").Row
  If Err.Number Then
    Err.Clear
    Col = InputBox("Nhap sai, Nhap lai Ky Tu Cot muon tim, nhu A, B, C ... ")
    GoTo Trolai
  End If
  Col = UCase(Col)
  With CreateObject("Scripting.Dictionary")
    For Each Sh In Worksheets
      ShName = Sh.Name
      If ShName <> "Sheet1" Then
        lRow = Sh.Range(Col & Rows.Count).End(xlUp).Row
        If lRow = 1 Then lRow = 2
        dArr = Sh.Range(Col & 1).Resize(lRow).Value
        For i = 1 To UBound(dArr)
          key = UCase(dArr(i, 1))
          If key <> "" Then
            If Not .exists(key) Then
              .Add key, Array(ShName, Col & i, dArr(i, 1))
            Else
              If IsArray(.Item(key)) Then .Item(key) = 1
            End If
          End If
        Next i
      End If
    Next Sh
    ReDim Arr(1 To .Count, 1 To 3)
    For i = 0 To .Count - 1
      dArr = .items()(i)
      If IsArray(dArr) Then
        k = k + 1
        Arr(k, 1) = dArr(0): Arr(k, 2) = dArr(1): Arr(k, 3) = dArr(2)
      End If
    Next i
  End With
  With Sheet1
    .Range("A2", .Range("C" & .Range("A2").End(xlDown).Row)).ClearContents
    .Range("A2").Resize(k, 3) = Arr
  End With
End Sub
 
Chào các Anh Chị Diễn đàn GPE !
Sau khi tìm được các giá trị không trùng thì lại phải ngồi copy từng dòng số liệu mà số liệu thì lớn quá nên vật vã lắm. Em nhờ các Anh Chị code thêm phần copy dòng số liệu không trùng đó về sheet1 như file đính kèm.
Ps: Em đang cần gấp ạ !
Em cám ơn !
 

File đính kèm

thanhthat đã viết:
Chào các Anh Chị Diễn đàn GPE !
Sau khi tìm được các giá trị không trùng thì lại phải ngồi copy từng dòng số liệu mà số liệu thì lớn quá nên vật vã lắm. Em nhờ các Anh Chị code thêm phần copy dòng số liệu không trùng đó về sheet1 như file đính kèm.
Ps: Em đang cần gấp ạ !
Em cám ơn !
Nhấp chuột vào đây để mở rộng...
Đã có địa chỉ, lấy thêm dữ liệu các cột khác không khó đâu, bạn tự viết code, có gì mình chỉnh lại

ReDim Arr(1 To .Count, 1 To 3) chỉnh số 3 lại

k = k + 1
Arr(k, 1) = dArr(0): Arr(k, 2) = dArr(1): Arr(k, 3) = dArr(2)
thêm các lệnh Arr(k, 4) = .... hoặc dùng for

chỉnh lại lệnh xuất kết quả
 
HieuCD đã viết:
Đã có địa chỉ, lấy thêm dữ liệu các cột khác không khó đâu, bạn tự viết code, có gì mình chỉnh lại

ReDim Arr(1 To .Count, 1 To 3) chỉnh số 3 lại

k = k + 1
Arr(k, 1) = dArr(0): Arr(k, 2) = dArr(1): Arr(k, 3) = dArr(2)
thêm các lệnh Arr(k, 4) = .... hoặc dùng for

chỉnh lại lệnh xuất kết quả
Nhấp chuột vào đây để mở rộng...
Em đang bận với nhiều số liệu nên cũng chưa viết đc với lai viết về mảng em không có rành lắm. Cám ơn anh nhiều.
 
Dear anh chị
Em có hai sheet có cột dữ liệu project code : Sheet "Project 2018" và sheet "finished". Em muốn tạo sheet "WIP" có mẫu giống như sheet 'project 2018" nhưng loại bỏ các project code đã có trong sheet "finished". Em nhờ anh chị giúp em tạo code VBA ạ. Em xin cám ơn ạ
 

File đính kèm

fullmoon2111 đã viết:
Dear anh chị
Em có hai sheet có cột dữ liệu project code : Sheet "Project 2018" và sheet "finished". Em muốn tạo sheet "WIP" có mẫu giống như sheet 'project 2018" nhưng loại bỏ các project code đã có trong sheet "finished". Em nhờ anh chị giúp em tạo code VBA ạ. Em xin cám ơn ạ
Nhấp chuột vào đây để mở rộng...
PHP: 
 Sub Laydulieu()
    Dim Dic As Object, sArr(), dArr(), tArr()
    Dim I As Long, J As Long, K As Long
Set Dic = CreateObject("Scripting.Dictionary")
With Sheets("Finished services")
    tArr = .Range("K6", .Range("K" & Rows.Count).End(3)).Value
End With
For I = 1 To UBound(tArr)
    Dic.Item(CStr(tArr(I, 1))) = I
Next I
With Sheets("Project 2018")
    sArr = .Range("A4", .Range("A" & Rows.Count).End(3)).Resize(, 21).Value
    ReDim dArr(1 To UBound(sArr, 1), 1 To UBound(sArr, 2))
    For I = 1 To UBound(sArr)
        If Not Dic.Exists(CStr(sArr(I, 4))) Then
            K = K + 1
            For J = 1 To 21
                dArr(K, J) = sArr(I, J)
            Next J
        End If
    Next I
End With
With Sheets("WIP")
    If K Then
        .Range("A4:X10000").ClearContents
        .Range("A4").Resize(K, UBound(sArr, 2)) = dArr
    End If
End With
Set Dic = Nothing
End Sub
 
Lần chỉnh sửa cuối:
Macro của bạn đây (tuy chậm chân rồi); Chúc vui vẻ & thành công:
PHP: 
Sub CopyRowsNotInFinishedServices()
 Dim Arr(), Sh As Worksheet, sArr(), Tmp As Boolean
 Dim Rws As Long, Col As Byte, J As Long, Dm As Byte, W As Long, Z As Long

 Sheets("Project 2018").Select
 Rws = [d3].CurrentRegion.Rows.Count
 Col = [d3].CurrentRegion.Columns.Count
 Arr() = [a4].Resize(Rws, Col).Value
 ReDim dArr(1 To Rws, 1 To Col)
 Sheets("WIP").[a4].Resize(Rws, Col).Value = dArr()
 With Sheets("Finished services")
    Rws = .[b5].CurrentRegion.Rows.Count
    sArr() = .[k6].Resize(Rws).Value
 End With
 For J = 1 To UBound(Arr())
    For Z = 1 To UBound(sArr())
        If Arr(J, 4) = sArr(Z, 1) Then
            Tmp = True:         Exit For
        End If
    Next Z
    If Tmp Then
        Tmp = False
    Else
        W = W + 1
        For Dm = 1 To Col
            dArr(W, Dm) = Arr(J, Dm)
        Next Dm
    End If
 Next J
 Sheets("WIP").[a4].Resize(W, Col).Value = dArr()
End Sub
 
PacificPR đã viết:
PHP: 
 Sub Laydulieu()
    Dim Dic As Object, sArr(), dArr(), tArr()
    Dim I As Long, J As Long, K As Long
Set Dic = CreateObject("Scripting.Dictionary")
With Sheets("Finished services")
    tArr = .Range("K6", .Range("K" & Rows.Count).End(3)).Value
End With
For I = 1 To UBound(tArr)
    Dic.Item(CStr(tArr(I, 1))) = I
Next I
With Sheets("Project 2018")
    sArr = .Range("A4", .Range("A" & Rows.Count).End(3)).Resize(, 21).Value
    ReDim dArr(1 To UBound(sArr, 1), 1 To UBound(sArr, 2))
    For I = 1 To UBound(sArr)
        If Not Dic.Exists(CStr(sArr(I, 4))) Then
            K = K + 1
            For J = 1 To 21
                dArr(K, J) = sArr(I, J)
            Next J
        End If
    Next I
End With
With Sheets("WIP")
    If K Then
        .Range("A4:X10000").ClearContents
        .Range("A4").Resize(K, UBound(sArr, 2)) = dArr
    End If
End With
Set Dic = Nothing
End Sub
Nhấp chuột vào đây để mở rộng...
**
Mình đã thử rồi nhưng giá trị ở cột Cost-USD và Cost - VND không hiện lên ạ
 
Hoang2013 đã viết:
Macro của bạn đây (tuy chậm chân rồi); Chúc vui vẻ & thành công:
PHP: 
Sub CopyRowsNotInFinishedServices()
 Dim Arr(), Sh As Worksheet, sArr(), Tmp As Boolean
 Dim Rws As Long, Col As Byte, J As Long, Dm As Byte, W As Long, Z As Long

 Sheets("Project 2018").Select
 Rws = [d3].CurrentRegion.Rows.Count
 Col = [d3].CurrentRegion.Columns.Count
 Arr() = [a4].Resize(Rws, Col).Value
 ReDim dArr(1 To Rws, 1 To Col)
 Sheets("WIP").[a4].Resize(Rws, Col).Value = dArr()
 With Sheets("Finished services")
    Rws = .[b5].CurrentRegion.Rows.Count
    sArr() = .[k6].Resize(Rws).Value
 End With
 For J = 1 To UBound(Arr())
    For Z = 1 To UBound(sArr())
        If Arr(J, 4) = sArr(Z, 1) Then
            Tmp = True:         Exit For
        End If
    Next Z
    If Tmp Then
        Tmp = False
    Else
        W = W + 1
        For Dm = 1 To Col
            dArr(W, Dm) = Arr(J, Dm)
        Next Dm
    End If
 Next J
 Sheets("WIP").[a4].Resize(W, Col).Value = dArr()
End Sub
Nhấp chuột vào đây để mở rộng...
Mình đã thử nhung trên sheet WIP vẫn còn giá trị trùng ạ. VD : project code 37743 đã có trên sheet Finishes thì không có trên sheet WIP nữa ạ.
 
ndu96081631 đã viết:
2 cột điểm thì cũng vẫn dùng Consolidate thôi ---> Add vào 2 vùng C2:D25 và C2:E5
Để bạn đở mất công làm bằng tay, tôi viết nó thành code... bạn chỉ việc nhấn nút là xong!
PHP: 
Sub DiemTB()
  Range("I1").CurrentRegion.Offset(1).ClearContents
  With Range([C2], [C65536].End(xlUp))
    Range("I2").Consolidate _
    Array(.Resize(, 2).Address(, , 2), .Resize(, 3).Address(, , 2)), 1, False, True
  End With
End Sub
Nhấp chuột vào đây để mở rộng...
Thầy cho em hỏi, em muốn đổi điểm trung bình thành tổng điểm thì mình sữa lại chỗ nào.
Em thấy code thầy hay và gọn nên áp dụng
Em cám ơn
 
MinhCong đã viết:
Bạn cứ thử sửa lại như vầy xem sao:
Mã: 
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Range("[COLOR=red]F2:G65536[/COLOR]").Clear
  With Range("[COLOR=red]B2:C[/COLOR]" & [[COLOR=red]B65536[/COLOR]].End(xlUp).Row)
     Range("[COLOR=red]F2[/COLOR]").Consolidate .Address(, , 2), Function:=xlSum, LeftColumn:=True
  End With
End Sub
Nhấp chuột vào đây để mở rộng...
Chào anh
Em muốn lọc trùng như vậy mà qua sheet"Total" thì mình chỉnh code như thế nào anh, nhờ anh giúp đỡ
Em cám ơn
 

File đính kèm

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. (3 người xem)
Trả lời
13
Đọc
102
Hoàng Tuấn 868
H
1
Hỏi về đánh dấu hàng ngang hàng dọc bằng màu khi kích chuột vào 1 ô
Trả lời
7
Đọc
175
Gà Công Nghệ
Gà Công Nghệ
PhanTuHuong
Sách Lập trình VBA trong AutoCAD đã có mặt
    • Thích
    • Yêu thích
2
Trả lời
20
Đọc
1K
Mr.hieudoanxd
Mr.hieudoanxd
P
Excell code vba : Tìm Cell để sửa dữ liệu
    • Buồn
2
Trả lời
26
Đọc
520
Phạm Trường 80
P
L
Lỗi font khi convert từ pdf
Trả lời
1
Đọc
54
Hoàng Tuấn 868
H
D
Nhờ anh em giúp đỡ.
    • Buồn
Trả lời
2
Đọc
76
SA_DQ
SA_DQ
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
2
Đọc
75
DeTong
D
H
Đổi số thành chữ trong office 365
Trả lời
19
Đọc
1K
HoangTan891026
H
Gà Công Nghệ
Lấy dữ liệu file excel từ sheet này sang sheet khác
Trả lời
4
Đọc
129
Gà Công Nghệ
Gà Công Nghệ
N
Mong mọi người giúp đỡ
Trả lời
1
Đọc
59
minhminh27
minhminh27
minhduc1o2
Excel lỗi font Time New Roman+
Trả lời
7
Đọc
116
minhduc1o2
minhduc1o2
F
  • Question Question
Tự động Merge Mail bằng VBA
Trả lời
0
Đọc
75
fujishima
F
H
Lọc dữ liệu trong XL
    • Cười
Trả lời
0
Đọc
46
huong.dinh
H
giaiphap
Add-Ins hổ trợ Word trộn danh sách và lưu ra nhiều tệp tin khác nhau.
    • Thích
    • Yêu thích
    • Cảm ơn
2
Trả lời
39
Đọc
9K
fujishima
F
K
xin file excel bảng đấu bóng đá
    • Yêu thích
2 3
Trả lời
40
Đọc
25K
subin1905
S
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.
    • Thích
2
Trả lời
24
Đọc
7K
chihuumvc
C
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
1
Đọc
65
bebo021999
B
G
Hướng dẫn Lập danh sách File
    • Không thích
Trả lời
16
Đọc
268
thanhhuy_hvnh
thanhhuy_hvnh
baolong240793
Nhờ Anh/Chị hỗ trợ em hàm Randbetween() với ạ.
Trả lời
4
Đọc
362
bebo021999
B
Y
  • Question Question
Khóa VBA với mật khẩu mở
    • Thích
2 3 4
Trả lời
60
Đọc
5K
PhanTuHuong
PhanTuHuong
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