Page 1 of 1
[VBA] Functions Search button
Posted: Thu Apr 27, 2017 9:04 am
by 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
Re: [VBA] Functions Search button
Posted: Thu Apr 27, 2017 4:14 pm
by logic
แจ้งเพื่อทราบครับ การวางโค้ดในช่องความเห็นให้อ่านกฎข้อ 5 ด้านบนครับ
Re: [VBA] Functions Search button
Posted: Fri Apr 28, 2017 8:13 am
by 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
Re: [VBA] Functions Search button
Posted: Fri Apr 28, 2017 8:20 am
by 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 ในส่วนไหน อย่างไรบ้างคะ ****
ขอบคุณค่ะ
Re: [VBA] Functions Search button
Posted: Fri Apr 28, 2017 10:01 am
by puriwutpokin
kannaree wrote:ขอบคุณค่ะ
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
Re: [VBA] Functions Search button
Posted: Fri Apr 28, 2017 10:09 am
by puriwutpokin
kannaree wrote:ขอถามอีกคำถามหนึงได้ไหมค่ะ
พอดีพึ่งจะเริ่มหัดเขียน 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
Re: [VBA] Functions Search button
Posted: Fri Apr 28, 2017 2:49 pm
by 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 ที่ส่งข้อมูลกลับมา
ไม่ทรายสาเหตุที่แท้จริง จริงๆ ค่ะ รบกวนหน่อยนะคะ
ขอบคุณมากค่ะ
Re: [VBA] Functions Search button
Posted: Fri Apr 28, 2017 5:58 pm
by snasui
ช่วยอธิบายคำว่าไม่ครบมาอีกทีครับว่าไม่ครบอย่างไร ทำตัวอย่างข้อมูลมาสักไม่เกิน 10 บรรทัด แล้วแนบไฟล์พร้อม Code มาใหม่จะได้สะดวกในการช่วยตรวจสอบครับ
Re: [VBA] Functions Search button
Posted: Fri Apr 28, 2017 7:39 pm
by 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
Re: [VBA] Functions Search button
Posted: Tue May 02, 2017 8:22 am
by kannaree
เมือแก้ไขตามโค้ด ของ K.puriwutpokin
ข้อมูลถูกต้องแล้วค่ะ ขอบคุณมากๆ นะคะ