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

Liên hệ QC
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

  • LOC VA LAY GIA TRI KHONG TRUNG (1).xlsm
    20.8 KB · Đọc: 23
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

  • LOC VA LAY GIA TRI KHONG TRUNG.xlsm
    22.2 KB · Đọc: 5
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

  • LOC VA LAY GIA TRI KHONG TRUNG.xlsm
    22.1 KB · Đọc: 10
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

  • tests.xlsm
    1 MB · Đọc: 12
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

  • Loc du lieu trung bang Consolidate (2).xls
    32.5 KB · Đọc: 10
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

Bich2B
lỗi định dạng ngày không đọc được công thức excel
Trả lời
0
Đọc
1
Bich2B
Bich2B
E
Nhờ các anh/chị giúp đỡ VBA trích xuất dữ liệu ra bảng biểu cố định
Trả lời
4
Đọc
18
hoangtuan.net
hoangtuan.net
hongphuong1997
  • Question
Lấy ký tự trong chuỗi theo nhiều điều kiện
Trả lời
9
Đọc
145
hoangtuan.net
hoangtuan.net
phuyen89
  • Question
Hạn chế số ngày sử dụng của File
2 3
Trả lời
45
Đọc
10K
hoangtuan.net
hoangtuan.net
NguyenNhan789556
  • Question
Viết code trong VBA
Trả lời
13
Đọc
90
SA_DQ
SA_DQ
Xem thêm…

Facebook

Giaiphapexcel.com

Group

DIỄN ĐÀN GIẢI PHÁP EXCEL

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

Back
Top Bottom