Code VBA tìm kiếm tất cả các giá trị thỏa mãn điều kiện tìm kiếm

Liên hệ QC

cuongDG

Thành viên mới
Tham gia
21/11/17
Bài viết
12
Được thích
0
Giới tính
Nam
- Nhờ các Pro viết giúp em code VBA tìm kiếm tất cả các giá trị thỏa mãn điều kiện tìm kiếm như file em đính kèm
- Em đang muốn viết VBA cho file này để tìm kiếm dữ liệu cho nhanh vì dùng Hàm với lượng dữ liệu nhiều máy đơ rất lâu.
- Cảm ơn các Pro trước!
 

File đính kèm

  • Raw data.xlsx
    12.5 KB · Đọc: 34
- Nhờ các Pro viết giúp em code VBA tìm kiếm tất cả các giá trị thỏa mãn điều kiện tìm kiếm như file em đính kèm
- Em đang muốn viết VBA cho file này để tìm kiếm dữ liệu cho nhanh vì dùng Hàm với lượng dữ liệu nhiều máy đơ rất lâu.
- Cảm ơn các Pro trước!
Không phải pro thì không được viết à bạn.Chỉ tuyển pro không tuyển gà.:D
Đây bạn ơi gà có 1 đoạn code bạn xem áp dụng nhé.
Mã:
Sub copy()
Sheets("Raw").Range("A4:d16").AdvancedFilter Action:=xlFilterCopy, Criteriarange:=Sheets("Data").Range("C5:D6"), copytorange:=Sheets("Data").Range("C8:F8"), unique:=False
End Sub
 
Lần chỉnh sửa cuối:
Không phải pro thì không được viết à bạn.Chỉ tuyển pro không tuyển gà.:D
Đây bạn ơi gà có 1 đoạn code bạn xem áp dụng nhé.
Mã:
Sub copy()
Sheets("Raw").Range("A4:d16").AdvancedFilter Action:=xlFilterCopy, Criteriarange:=Sheets("Data").Range("C5:D6"), copytorange:=Sheets("Data").Range("C8:F8"), unique:=False
End Sub
Không được bạn ơi
Ai viết được code VBA đều gọi là pro rồi bạn =))
 
- Nhờ các Pro viết giúp em code VBA tìm kiếm tất cả các giá trị thỏa mãn điều kiện tìm kiếm như file em đính kèm
- Em đang muốn viết VBA cho file này để tìm kiếm dữ liệu cho nhanh vì dùng Hàm với lượng dữ liệu nhiều máy đơ rất lâu.
- Cảm ơn các Pro trước!
Mã:
Sub TimKiem()
Dim Nguon, Dk, Kq(1 To 1, 1 To 2)
Dim i
Nguon = Sheet1.Range("a5:d6")
Dk = Sheet2.Range("c6:d6")
For i = 1 To UBound(Nguon)
    If Nguon(i, 1) & "_" & Nguon(i, 2) = Dk(1, 1) & "_" & Dk(1, 2) Then
        Kq(1, 1) = Kq(1, 1) & " " & Nguon(i, 3)
        Kq(1, 2) = Kq(1, 2) & " " & Nguon(i, 4)
    End If
Next i
Sheet2.Range("e6:f6") = Kq
End Sub
 
Bạn thử thay công thức vào file đấy thử xem không được mà. Nếu được bạn up file thay công thức cho mình xin
Bài đã được tự động gộp:

Mã:
Sub TimKiem()
Dim Nguon, Dk, Kq(1 To 1, 1 To 2)
Dim i
Nguon = Sheet1.Range("a5:d6")
Dk = Sheet2.Range("c6:d6")
For i = 1 To UBound(Nguon)
    If Nguon(i, 1) & "_" & Nguon(i, 2) = Dk(1, 1) & "_" & Dk(1, 2) Then
        Kq(1, 1) = Kq(1, 1) & " " & Nguon(i, 3)
        Kq(1, 2) = Kq(1, 2) & " " & Nguon(i, 4)
    End If
Next i
Sheet2.Range("e6:f6") = Kq
End Sub
Code không được bạn CHAOQUAY ah!
 
Bạn thử thay công thức vào file đấy thử xem không được mà. Nếu được bạn up file thay công thức cho mình xin
Bài đã được tự động gộp:


Code không được bạn CHAOQUAY ah!
Đây có thấy lỗi nào đâu nhỉ.
 

File đính kèm

  • Raw data (1).xlsm
    18.4 KB · Đọc: 11
Bạn có thể ghi chung các giá trị tìm kiếm vào một dòng được không, cái này đang thành hai dòng. Cảm ơn bạn nhiều!
Cái này là 1 dòng kết quả 1 dòng điều kiện mà.Ai lại để chung kết quả với điều kiện chung.
 

File đính kèm

  • TimKiem.rar
    787.3 KB · Đọc: 5
Nhưng code này không tìm được theo hai điều kiện b ah và không tìm các giá trị thỏa mãn cùng 1 điều kiện, chỉ tìm được giá trị đầu tiên thôi.
Bạn xem code nhé.
Mã:
Sub timkiem()
Dim arr, arr1, lr As Long, i As Long, dk As String, dks As String, a As Long
With Sheets("Raw")
     lr = .Range("A" & Rows.Count).End(xlUp).Row
     If lr < 5 Then Exit Sub
     arr = .Range("A5:D" & lr).Value
End With
With Sheets("DAta")
     dk = CLng(.Range("C6").Value) & "#" & .Range("D6").Value
     ReDim arr1(1 To UBound(arr, 1), 1 To 2)
     For i = 1 To UBound(arr, 1)
         dks = CLng(arr(i, 1)) & "#" & arr(i, 2)
         If UCase(dk) = UCase(dks) Then
            a = a + 1
            arr1(a, 1) = arr(i, 3)
            arr1(a, 2) = arr(i, 4)
         End If
    Next i
    lr = .Range("E" & Rows.Count).End(xlUp).Row
    If lr > 5 Then .Range("E6:F" & lr).ClearContents
    If a Then .Range("E6").Resize(a, 2).Value = arr1
End With
End Sub
 

File đính kèm

  • Raw data (2).xlsm
    19.5 KB · Đọc: 18
Bạn xem code nhé.
Mã:
Sub timkiem()
Dim arr, arr1, lr As Long, i As Long, dk As String, dks As String, a As Long
With Sheets("Raw")
     lr = .Range("A" & Rows.Count).End(xlUp).Row
     If lr < 5 Then Exit Sub
     arr = .Range("A5:D" & lr).Value
End With
With Sheets("DAta")
     dk = CLng(.Range("C6").Value) & "#" & .Range("D6").Value
     ReDim arr1(1 To UBound(arr, 1), 1 To 2)
     For i = 1 To UBound(arr, 1)
         dks = CLng(arr(i, 1)) & "#" & arr(i, 2)
         If UCase(dk) = UCase(dks) Then
            a = a + 1
            arr1(a, 1) = arr(i, 3)
            arr1(a, 2) = arr(i, 4)
         End If
    Next i
    lr = .Range("E" & Rows.Count).End(xlUp).Row
    If lr > 5 Then .Range("E6:F" & lr).ClearContents
    If a Then .Range("E6").Resize(a, 2).Value = arr1
End With
End Sub
Bạn đợi mình gửi file có data lớn bạn thử viết code xem được không nhá.
 
Mình viết được code nhưng mà mình hông phải pro nên hông post code hihibi
 
File đây nha b, hôm qua mình có việc nên chưa up data lên được. b viết giúp mình nhá.
Bạn chạy thử code.
Mã:
Sub chuyendulieu()
Dim arr, i As Long, lr As Long, dic As Object
Set dic = CreateObject("scripting.dictionary")
    With Sheets("Issue")
         lr = .Range("C" & Rows.Count).End(xlUp).Row
         arr = .Range("c2:D" & lr).Value
         For i = 1 To UBound(arr, 1)
             If Not dic.exists(arr(i, 1)) Then
                dic.Add arr(i, 1), arr(i, 2)
             Else
                dic.Item(arr(i, 1)) = dic.Item(arr(i, 1)) & "-" & arr(i, 2)
             End If
         Next i
    End With
    With Sheets("Data")
          lr = .Range("i" & Rows.Count).End(xlUp).Row
          arr = .Range("i2:Y" & lr).Value
          For i = 1 To UBound(arr, 1)
              If dic.exists(arr(i, 1)) Then
                 arr(i, 17) = dic.Item(arr(i, 1))
              End If
          Next i
          .Range("i2:Y" & lr).Value = arr
    End With
    Set dic = Nothing
End Sub
 
Bạn chạy thử code.
Mã:
Sub chuyendulieu()
Dim arr, i As Long, lr As Long, dic As Object
Set dic = CreateObject("scripting.dictionary")
    With Sheets("Issue")
         lr = .Range("C" & Rows.Count).End(xlUp).Row
         arr = .Range("c2:D" & lr).Value
         For i = 1 To UBound(arr, 1)
             If Not dic.exists(arr(i, 1)) Then
                dic.Add arr(i, 1), arr(i, 2)
             Else
                dic.Item(arr(i, 1)) = dic.Item(arr(i, 1)) & "-" & arr(i, 2)
             End If
         Next i
    End With
    With Sheets("Data")
          lr = .Range("i" & Rows.Count).End(xlUp).Row
          arr = .Range("i2:Y" & lr).Value
          For i = 1 To UBound(arr, 1)
              If dic.exists(arr(i, 1)) Then
                 arr(i, 17) = dic.Item(arr(i, 1))
              End If
          Next i
          .Range("i2:Y" & lr).Value = arr
    End With
    Set dic = Nothing
End Sub
Được rồi bạn ah, pro quá =)) thanks b nhá!
 
Web KT
Back
Top Bottom