[VBA] Functions Search button

[kannaree]

สวัสดีค่ะ ขอสอบถามหน่อยค่ะ ว่าถ้าหากข้อมูลที่ค่าที่ซ้ำกัน ต้องการ Search และข้อมูลแสดงทั้งหมด
จะต้องเขียนโค้ด vba อย่างไรค่ะ

Sheet Data1

11.png

Sheet Result > เมื่อกดปุ่ม Search

2.png

จะเห็นว่ามีข้อมูล Jacob White 2 บรรทัด แต่แสดงบรรทัดเดียว



Code

Sub searchtest()
Dim lastrow As Long, x As Long

lastrow = Sheets("data2").Cells(Rows.Count, 1).End(xlUp).Row


For x = 2 To lastrow
If Sheets("data2").Cells(x, 1).Value = Sheets("Result").Range("a2").Value And Sheets("data2").Cells(x, 2).Value = Sheets("Result").Range("b2").Value Then
Sheets("Result").Range("c2").Value = Sheets("data2").Cells(x, 3).Value
Exit Sub
End If
Next x




End Sub



File :

copyColumns autpmate.xlsm

[logic]

แจ้งเพื่อทราบครับ การวางโค้ดในช่องความเห็นให้อ่านกฎข้อ 5 ด้านบนครับ

[kannaree]

ขอบคุณค่ะ

Code: Select all

Sub searchtest()
Dim lastrow As Long, x As Long

lastrow = Sheets("data2").Cells(Rows.Count, 1).End(xlUp).Row


For x = 2 To lastrow
 If Sheets("data2").Cells(x, 1).Value = Sheets("Result").Range("a2").Value And Sheets("data2").Cells(x, 2).Value = Sheets("Result").Range("b2").Value Then
 Sheets("Result").Range("c2").Value = Sheets("data2").Cells(x, 3).Value
 Exit Sub
 End If
Next x




End Sub

[kannaree]

ขอถามอีกคำถามหนึงได้ไหมค่ะ

พอดีพึ่งจะเริ่มหัดเขียน vba

มีข้อมูลอยู่ใน Sheet "data3"

ใช้สูตร Unique ในการ Find หาข้อมูลในเซล A

ให้แสดงผลลัพทธ์ ตัดค่าที่ซ้ำกันออก ผลลัพธ์ในเซลล์ F ตามรูป

1112.png

Code: Select all

Sub A_Unique_B()
Dim X
Dim objDict As Object
Dim lngRow As Long

Set objDict = CreateObject("Scripting.Dictionary")
X = Application.Transpose(Range([a1], Cells(Rows.Count, "A").End(xlUp)))

For lngRow = 1 To UBound(X, 1)
    objDict(X(lngRow)) = 1
Next
Range("F2:F" & objDict.Count) = Application.Transpose(objDict.Keys)
End Sub

>> อยากให้ข้อมูลไปแสดงใน Sheet3 cell C8 จะต้องแก้ Code ในส่วนไหน อย่างไรบ้างคะ ****

ขอบคุณค่ะ

[puriwutpokin]

ขอบคุณค่ะ

Code: Select all

Sub searchtest()
Dim lastrow As Long, x As Long

lastrow = Sheets("data2").Cells(Rows.Count, 1).End(xlUp).Row


For x = 2 To lastrow
 If Sheets("data2").Cells(x, 1).Value = Sheets("Result").Range("a2").Value And Sheets("data2").Cells(x, 2).Value = Sheets("Result").Range("b2").Value Then
 Sheets("Result").Range("c2").Value = Sheets("data2").Cells(x, 3).Value
 Exit Sub
 End If
Next x




End Sub

ตอบอันนี้ก่อนครับปรับโค้ดตามนี้ครับ

Code: Select all

Sub FilterAndCopy()
Dim wstSource As Worksheet, _
    wstOutput As Worksheet
Dim rngMyData As Range, _
    helperRng As Range
Set wstSource = Worksheets("Data2")
Set wstOutput = Worksheets("Result")
Application.ScreenUpdating = False
With wstSource
    Set rngMyData = .Range("A2:C" & .Range("A" & .Rows.Count).End(xlUp).Row)
End With
Set helperRng = rngMyData.Offset(, rngMyData.Columns.Count + 1).Resize(, 1)
With helperRng
    .FormulaR1C1 = "=if(countif(C1,RC1)>1,"""",1)"
    .Value = .Value
    .SpecialCells(xlCellTypeBlanks).EntireRow.Copy Destination:=wstOutput.Cells(1, 1)
    .ClearContents
End With
Application.ScreenUpdating = True
End Sub

[puriwutpokin]

ขอถามอีกคำถามหนึงได้ไหมค่ะ

พอดีพึ่งจะเริ่มหัดเขียน vba

มีข้อมูลอยู่ใน Sheet "data3"

ใช้สูตร Unique ในการ Find หาข้อมูลในเซล A

ให้แสดงผลลัพทธ์ ตัดค่าที่ซ้ำกันออก ผลลัพธ์ในเซลล์ F ตามรูป
1112.png

Code: Select all

Sub A_Unique_B()
Dim X
Dim objDict As Object
Dim lngRow As Long

Set objDict = CreateObject("Scripting.Dictionary")
X = Application.Transpose(Range([a1], Cells(Rows.Count, "A").End(xlUp)))

For lngRow = 1 To UBound(X, 1)
    objDict(X(lngRow)) = 1
Next
Range("F2:F" & objDict.Count) = Application.Transpose(objDict.Keys)
End Sub

>> อยากให้ข้อมูลไปแสดงใน Sheet3 cell C8 จะต้องแก้ Code ในส่วนไหน อย่างไรบ้างคะ ****

ขอบคุณค่ะ

ปรับตามนี้ครับ

Code: Select all

Sub A_Unique_B()
Dim X
Dim objDict As Object
Dim lngRow As Long
Set objDict = CreateObject("Scripting.Dictionary")
X = Application.Transpose(Range([a1], Cells(Rows.Count, "A").End(xlUp)))
For lngRow = 1 To UBound(X, 1)
    objDict(X(lngRow)) = 1
Next
Sheets("Sheet3").Range("C1:C" & objDict.Count).Offset(7, 0) = Application.Transpose(objDict.Keys)
End Sub

[kannaree]

ขอบคุณ คุณ puriwutpokin มาก ๆ ค่ะ ได้ทำการแก้โค้ดไปแล้วในก่อนหน้านี้

ติดปัญหานิดหน่อยตรง ข้อ 2 ใช้สูตร Unique ในการ Find หาข้อมูล เนื่องจาก ข้อมูลจริงมีประมาณ 50,000 บรรทัด
แต่เมื่อเขียนโค้ด ใช้สูตร Unique ข้อมูลแสดงไม่ครบ ไม่ทราบว่าเกิดจากตรงไหน และจะแก้ที่ส่วนใดคะ

sheet1 ลองตัวอย่าง 5000 บรรทัด

33333.png

ผลลัพธ์ที่ข้อมูลไม่ครบ

44444.png

Code: Select all

Sub summaryReport()
Dim X
Dim objDict As Object
Dim lngRow As Long

Set objDict = CreateObject("Scripting.Dictionary")
Sheet1.Select
X = Application.Transpose(Range([a2], Cells(Rows.Count, "A").End(xlUp)))

For lngRow = 1 To UBound(X, 1)
    objDict(X(lngRow)) = 1
     
Next
  
  

Sheet3.Select
Range("C7:C" & objDict.Count) = Application.Transpose(objDict.Keys)
End Sub

Code: Select all

Application.Transpose(Range([a2], Cells(Rows.Count, "A").End(xlUp)))

โค้ดในส่วนนี้ไม่ใช่ Find หาทั้งคอลัม A หรอไม่คะ หรือว่าที่ข้อมูลไมม่ครบเป็นเพราะUBound ที่ส่งข้อมูลกลับมา
ไม่ทรายสาเหตุที่แท้จริง จริงๆ ค่ะ รบกวนหน่อยนะคะ


ขอบคุณมากค่ะ

[snasui]

ช่วยอธิบายคำว่าไม่ครบมาอีกทีครับว่าไม่ครบอย่างไร ทำตัวอย่างข้อมูลมาสักไม่เกิน 10 บรรทัด แล้วแนบไฟล์พร้อม Code มาใหม่จะได้สะดวกในการช่วยตรวจสอบครับ

[puriwutpokin]

คุณkannaree ไม่ทำตามโค้ดที่ให้ไป มีการแก้ไขไม่ถูก ปรับเป็นแบบนี้นะครับ

Code: Select all

Sub summaryReport()
Dim X
Dim objDict As Object
Dim lngRow As Long
Set objDict = CreateObject("Scripting.Dictionary")
X = Application.Transpose(Range([a2], Cells(Rows.Count, "A").End(xlUp)))
For lngRow = 1 To UBound(X, 1)
    objDict(X(lngRow)) = 1
Next
Sheet3.Range("C1:C" & objDict.Count).Offset(6, 0) = Application.Transpose(objDict.Keys)
End Sub

[kannaree]

เมือแก้ไขตามโค้ด ของ K.puriwutpokin
ข้อมูลถูกต้องแล้วค่ะ ขอบคุณมากๆ นะคะ