ค้นหาข้อมูลโดยใช้สูตรและคอลัมภ์ช่วย

[snasui]

Sheets("Database").Range("A3",Range("K" & Rows.Count).End(xlUp)).AdvancedFilter Action:=xlFilterInPlace, _
        CriteriaRange:=Sheets("Search").Range("M3:N4")

ลองเปลี่ยนเป็นตามด้านล่างครับ

Code: Select all

Sheets("Database").Range("A3",Sheets("Database").Range("K" & Rows.Count).End(xlUp)).AdvancedFilter Action:=xlFilterInPlace, _
        CriteriaRange:=Sheets("Search").Range("M3:N4")

และจาก

For Each r In rAll
    If r = Worksheets("Search").Range("F5") And r.Offset(0,1) = Worksheets("Search").Range("F6") Then

เป็นปกติที่จะไม่ได้คำตอบ เพราะผมเพียงแต่ยกตัวอย่างให้เห็นว่าสามารถปรับ Code ที่บรรทัดไหน เงื่อนไขจริง ๆ เป็นเช่นไรก็ให้ปรับเป็นเช่นนั้นครับ

[joo]

Code: Select all

Sheets("Database").Range("A3",Sheets("Database").Range("K" & Rows.Count).End(xlUp)).AdvancedFilter Action:=xlFilterInPlace, _
        CriteriaRange:=Sheets("Search").Range("M3:N4")

ทดลองตามโค๊ดนี้แล้วครับผลที่ได้ก็ยังเหมือนเดิมครับ สำหรับโค๊ดนี้

Code: Select all

For Each r In rAll
    If r = Worksheets("Search").Range("F5") And r.Offset(0,1) = Worksheets("Search").Range("F6") Then

ผมก็ได้ทดลองปรับตามที่อาจารย์แนะนำ ซึ่งตามเงื่อนไขจะอยู่ที่ซีท Search เซลล์ F5 และ F6 ถ้าอ้างอิงเฉพาะ F5 อย่างเดียวข้อมูลสามารถค้นหามาแสดงได้แต่ถ้าอ้างอิงทั้ง F5 และ F6
ระบบจะค้นหาข้อมูลไม่พบครับ จะต้องปรัแก้ไขโค๊ดอย่างไรดีครับ

[snasui]

ส่งไฟล์ที่ลองปรับแล้วมาด้วยครับ จะได้ช่วยกันดูต่อครับ

[joo]

ผมส่งไฟล์ตัวอย่างมาให้ช่วยดูแล้วครับตามโค๊ดที่อาจารย์แนะนำตัวอย่างอยู่ที่ซีท Search และ Search2 โค๊ดใน Modul1 และ Modul3 ครับ

[snasui]

เนื่องจากคอลัมน์ K ในชีท Database ไม่มีข้อมูลจึงไม่สามารถจะใช้คอลัมน์ K ในการกำหนดช่วงข้อมูลได้ สำหรับ Module3 ผมจึงปรับ Code มาให้ใหม่ตามด้านล่าง ลองทดสอบดูครับ

Code: Select all

Sub ShowDataTraining()
    On Error Resume Next
    Application.EnableEvents = False
    Sheets("Search").Range("C12:M65536").ClearContents
    Sheets("Database").Range("A3", Sheets("Database"). _
        Range("A" & Rows.Count).End(xlUp).Offset(0, 11)).AdvancedFilter Action:=xlFilterInPlace, _
        CriteriaRange:=Sheets("Search").Range("M3:N4")
    Sheets("Database").Range("A4", Sheets("Database"). _
        Range("A" & Rows.Count).End(xlUp).Offset(0, 11)).SpecialCells(xlCellTypeVisible).Copy
    Sheets("Search").Range("C12").PasteSpecial xlPasteValues
    Sheets("Database").ShowAllData
    Range("F4").Activate
    Application.CutCopyMode = False
    Application.EnableEvents = True
End Sub

สำหรับ Module1 ลองปรับ Code เป็นด้านล่างครับ

Code: Select all

For Each r In rAll
    If r = Worksheets("Search").Range("F5") And r.Offset(0, -1) = Worksheets("Search").Range("F6") Then

[joo]

ขอบคุณครับท่านอาจารย์
โค๊ดที่ Modul3 ทดลองดูแล้วเหมือนเดิมครับ คือข้อมูลจะแสดงออกมาหมดเลยครับจะไม่ตรงกับที่เลือกไว้
ส่วนโค๊ดที่ Modul1 ทดลองดูแล้วสามารถแสดงผลได้ตรงตามที่ต้องการครับ แต่ว่าต้องคีย์ข้อมูลถึง 2 เซลล์คือ ที่ F4 และ F6 โค๊ดจึงจะทำงาน ที่ต้องการคือเมื่อเซลล์ F4 หรือ F6 ในซีท Search มีการเปลี่ยนแปลงข้อมูลแล้วโค๊ดจึงค่อยทำงานโดยที่เงื่อนไขยังเหมือนเดิมครับ

[snasui]

ใน Module3 ผมปรับ Code ต่อจากคุณ bank9597 ต้องทดสอบกับไฟล์ที่คุณ bank9597 แนบมาให้ครับ ซึ่งเพิ่มเซลล์เข้ามาช่วยในการทำ Advance Filter แล้ว สำหรับ Module1 หากต้องการให้ Code ทำงานเมื่อมีการเปลี่ยนแปลงค่าในเซลล์ สามารถปรับที่ Change Event ให้ตรวจสอบว่าเมื่อค่าในเซลล์เป้าหมายเซลล์ใดเซลล์หนึ่งมีการเปลี่ยนแปลงก็ให้่ Code ทำงาน จากไฟล์ที่แนบมาล่าสุดก็มี Code แบบนี้อยู่แล้ว ลองปรับมาดูครับ

[joo]

เข้าใจแล้วครับท่านอาจารย์ผมนึกว่าอาจารย์แนะนำกับไฟล์แนบอบรม4 ผมได้ทดสอบกับไฟล์ตามที่อาจารย์แนะนำแล้วก็ใช้งานได้ดีครับ
ส่วนโค๊ดเมื่อมีการเปลี่ยนแปลงที่เซลล์เป้าหมายแล้วให้โค๊ดทำงานผมปรับโค๊ดที่ซีท Search แบบนี้ครับก็สามารถทำงานได้ดีครับ

Code: Select all

Private Sub Worksheet_Change(ByVal Target As Range)
     If Target.Address = "$F$4" And Target <> "" Then
           ShowDataTraining
       ElseIf Target.Address = "$F$6" And Target <> "" Then
           ShowDataTraining
      ElseIf Target.Address = "$F$4" And Target = "" Then
           MsgBox "Please select data."
End If
End Sub

ส่วนการค้นหาข้อมูลตามชื่อเดือนนั้นยังไม่ได้ครับไม่รู้จะลิงค์ข้อมูลที่ Database เซลล์ F4:F10 ให้สัมพันธ์กับซีท Search1 เซลล์ F4 ยังไงดีครับ

[snasui]

ยินดีด้วยครับ

กรณีดึงเป็นเดือนควรจะต้องทราบก่อนว่าต้องการดูเดือนจากคอลัมน์ใดในชีท Database ครับ

[joo]

กรณีดึงเป็นเดือนควรจะต้องทราบก่อนว่าต้องการดูเดือนจากคอลัมน์ใดในชีท Database ครับ

ดูได้จากคอลัมภ์ F ในซีท Database เป็นหลักครับ

[snasui]

ลองดูตัวอย่างการปรับ Code ตามด้านล่างครับ

Code: Select all

Option Explicit
Option Base 1

Sub ShowDataTraining1()
Dim a() As Variant, lng As Long
Dim r As Range, rAll As Range
Dim rt As Range, rl As Long
Dim m As Variant, i As Integer
Sheets("Search1").Range("B11:M65536").ClearContents
m = Array("มกราคม", "กุมภาพันธ์", "มีนาคม", "เมษายน", _
    "พฤษภาคม", "มิถุนายน", "กรกฎาคม", "สิงหาคม", _
    "กันยายน", "ตุลาคม", "พฤศจิกายน", "ธันวาคม")
i = Application.Match(Sheets("Search1").Range("F4"), m, 0)
Application.EnableEvents = False
Application.ScreenUpdating = False
rl = Rows.Count
With Worksheets("Database")
    Set rAll = .Range("B4", .Range("B" & rl).End(xlUp))
End With
For Each r In rAll
    If Month(r.Offset(0, 4)) = i And r.Offset(0, -1) = Worksheets("Search1").Range("F5") Then
        lng = lng + 1
        ReDim Preserve a(12, lng)
        a(1, lng) = lng
        a(2, lng) = r.Offset(0, -1)
        a(3, lng) = r.Offset(0, 0)
        a(4, lng) = r.Offset(0, 1)
        a(5, lng) = r.Offset(0, 2)
        a(6, lng) = r.Offset(0, 3)
        a(7, lng) = Application.Text(r.Offset(0, 4), "mm/dd/yyyy")
        a(8, lng) = Application.Text(r.Offset(0, 5), "mm/dd/yyyy")
        a(9, lng) = r.Offset(0, 6)
        a(10, lng) = r.Offset(0, 7)
        a(11, lng) = r.Offset(0, 8)
        a(12, lng) = r.Offset(0, 9)
       
    End If
Next r
If lng > 0 Then
  With Worksheets("Search1")
        Set rt = .Range("B11", .Range("M" & lng - 1 + 11))
        If .Range("B11") <> "" Then 'Check if isblank
             .Range(.Range("B11"), .Range("B" & rl).End(xlUp)).Offset(0, 4).ClearContents
        End If
        .Range("B11:M12").Copy
        rt.PasteSpecial xlPasteFormats
        rt = Application.Transpose(a)
    End With
Else
    MsgBox "Data not found."
End If
Application.CutCopyMode = False
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub

[joo]

ขอบคุณครับท่านอาจารย์
ผมได้ทดลองแล้วที่ซีท Serah1 ถ้าใช้โค๊ดนี้

Code: Select all

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = "$F$4" And Target <> "" Then
    ShowDataTraining1
ElseIf Target.Address = "$F$4" And Target = "" Then
    MsgBox "Please select data."
  End If
End Sub

จะเกิด bug ที่บรรทัดนี้ครับ

Code: Select all

If Target.Address = "$F$4" And Target <> "" Then

ไม่ทราบว่าเป็นเพราะสาเหตุอะไรผมจึงปรับมาใช้โค๊ดนี้แทนก็ใช้งานได้ดี

Code: Select all

Private Sub Worksheet_Change(ByVal Target As Range)
      If Not Intersect(Target, Range("F4:F5")) Is Nothing Then
        Call ShowDataTraining1
End If
End Sub

ที่ซีท Search1 ผมได้เพิ่มคอลัมภ์เพื่อแสดงข้อมูลเพิ่มเติมและก็ได้ปรับโค๊ดเพิ่ม ผลปรากฎว่าข้อมูลที่ N11 ไม่ยอมแสดงครับ แต่ที่ซีท Search ข้อมูลที่ N12 สามารถแสดงตามคอลัมภ์
ที่เพิ่มเข้ามาได้ครับแถมมีข้อมความ #N/A ต่อท้ายอีกไม่ทราบว่ามาจากไหนครับ

[snasui]

ที่ Error เช่นนั้นเพราะว่า F4 มีการ Merge เซลล์ไว้ครับ

และที่ข้อมูลแสดงไม่ครบเพราะว่ากำหนดช่วงข้อมูลเป้าหมายไว้น้อยไปกว่าข้อมูลที่จะวาง จากเดิม

Code: Select all

Set rt = .Range("B11", .Range("M" & lng - 1 + 11))

ให้แก้เป็น

Code: Select all

Set rt = .Range("B11", .Range("N" & lng - 1 + 11))

ส่วนที่แสดง #N/A เพราะกำหนดช่วงข้อมูลเป้าหมายไว้มากเกินไปกว่าข้อมูลที่จะวาง สังเกตการแก้ตามข้างบน

[joo]

ขอบคุณครับท่านอาจารย์ ที่แท้ซ่อนอยู่ที่บรรดทัดนี้นี่เองมองข้ามไปจริงๆ

ที่ Error เช่นนั้นเพราะว่า F4 มีการ Merge เซลล์ไว้ครับ

ส่วนนี้ผมลองปรับแก้แล้วครับแต่โค๊ดไม่ยอมทำงานครับ

[snasui]

ปรับแก้เป็นอย่างไร ช่วยโพสต์ Code ที่ปรับแก้แล้วยังทำงานไม่ได้มาด้วยครับ

[joo]

โค๊ดที่ปรับแก้แบบนี้ครับ

Code: Select all

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = "F4" And Target <> "" Then
    ShowDataTraining1
ElseIf Target.Address = "F4" And Target = "" Then
    MsgBox "Please select data."
      
End If
End Sub

[snasui]

เมื่ออ้างถึง .Address จะต้องใส่เครื่องหมาย $ เข้าไปกำกับด้วยเสมอ เนื่องจากเป็น String ซึ่งจะต้องเป็น "$F$4" ไม่ใช่เป็น "F4" ครับ

สำหรับ Merge เซลล์ ลองปรับจากเดิมจาก

Code: Select all

If Target.Address = "$F$4" And Target <> "" Then

เป็น

Code: Select all

If Target.Range("A1").Address = "$F$4" And Target.Range("A1") <> "" Then

จะเห็นว่ามีการเพิ่ม .Range("A1") เข้ามาช่วยเพื่อบอกโปรแกรมให้เข้าใจว่า เราต้องการใช้เฉพาะเซลล์แรกของเซลล์ที่นำมา Merge เข้าด้วยกัน และ Code บรรทัดอื่น ๆ ที่อ้างถึง F4 ก็ต้องปรับเช่นนี้ด้วยเช่นกันครับ

[joo]

ขอบคุณครับที่ช่วยชี้แนะแนวทางที่ถูกต้อง ได้ทดลองแล้วครับสามารถใช้งานได้ตรงตามที่ต้องการแล้วครับ

[joo]

ผมได้นำโค๊ดมาปรับใช้ค้นหาข้อมูลโดยให้แสดงข้อมูลในแนวตั้งดูบ้าง ที่ซีท Looks ข้อมูลที่แสดงออกมาไม่ตรงตามตำแหน่งที่ต้องการ ช่วยดูโค๊ดให้หน่อยครับว่าผิดพลาดตรงไหนครับ

Code: Select all

Option Explicit
Option Base 1

Sub ShowDetail()
Dim a() As Variant, lng As Long
Dim r As Range, rAll As Range
Dim rt As Range, rl As Long
Application.EnableEvents = False
Application.ScreenUpdating = False
rl = Rows.Count
With Worksheets("Database")
    Set rAll = .Range("B2", .Range("B" & rl).End(xlUp))
End With
For Each r In rAll
    If r = Worksheets("Looks").Range("D6") Then
        lng = lng + 1
        ReDim Preserve a(lng, 6)
        a(lng, 1) = lng
        a(lng, 2) = r.Offset(0, -1)
        a(lng, 3) = r.Offset(0, 0)
        a(lng, 4) = r.Offset(0, 1)
        a(lng, 5) = r.Offset(0, 2)
        a(lng, 6) = r.Offset(0, 3)
    End If
Next r
If lng > 0 Then
    With Worksheets("Looks")
        Set rt = .Range("C7", .Range("C" & lng + 1))
        .Range("C7", .Range("C" & rl).End(xlUp).Offset(0, 4)).ClearContents
        .Range("C8:C13").Copy
        rt.PasteSpecial xlPasteFormats
        rt = Application.Transpose(a)
        .Range("D6").Activate
    End With
Else
    MsgBox "Data not found."
End If
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub

[snasui]

ลองปรับ Code เป็นตามด้านล่างครับ

Code: Select all

Option Explicit
Option Base 1

Sub ShowDetail()
Dim a() As Variant, lng As Long
Dim r As Range, rAll As Range
Dim rt As Range, rl As Long
Application.EnableEvents = False
Application.ScreenUpdating = False
rl = Rows.Count
With Worksheets("Database")
    Set rAll = .Range("B2", .Range("B" & rl).End(xlUp))
End With
For Each r In rAll
    If r = Worksheets("Looks").Range("D6") Then
        lng = lng + 1
        ReDim Preserve a(lng, 6)
'        a(lng, 1) = lng
        a(lng, 1) = r.Offset(0, -1)
        a(lng, 2) = r.Offset(0, 0)
        a(lng, 3) = r.Offset(0, 1)
        a(lng, 4) = r.Offset(0, 2)
        a(lng, 5) = r.Offset(0, 3)
        a(lng, 6) = r.Offset(0, 4)
    End If
Next r
If lng > 0 Then
    With Worksheets("Looks")
        Set rt = .Range("C8").Resize(6, 1)
        .Range("C8", .Range("C" & rl).End(xlUp).Offset(0, 4)).ClearContents
'        .Range("C8:C13").Copy
'        rt.PasteSpecial xlPasteFormats
        rt = Application.Transpose(a)
        .Range("D6").Activate
    End With
Else
    MsgBox "Data not found."
End If
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub