VBA ค้นหาข้อมูลหลายชีตแล้ว Hyperlink ไม่ทำงาน

[LomHoun]

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

[snasui]

กรุณาแนบไฟล์พร้อม Code ที่เขียนไว้เองแล้วมาด้วย ชี้ให้เห็นว่าติดปัญหาที่ Module ไหน Procedure ใดตามกฎข้อ 5 ด้านบน จะได้สะดวกในการตอบของเพื่อนสมาชิกครับ

[LomHoun]

test.xlsm

Code: Select all

Sub SearchMultipleSheets()
    Dim arr(999, 10) As Variant, r As Range
    Dim ws As Worksheet, i As Integer, s As String
    With Sheets(1)
        s = .Range("c2").Value
        .Range("a5").Resize(.UsedRange.Rows.Count, _
            .UsedRange.Columns.Count).ClearContents
    End With
    For Each ws In Worksheets
        If ws.Name <> Sheets(1).Name Then
            With ws
                For Each r In .Range("a4", .Range("a" & .Rows.Count).End(xlUp))
                    If r.Value & r.Offset(0, 1).Value & r.Offset(0, 2).Value & _
                        r.Offset(0, 3).Value & r.Offset(0, 4).Value & r.Offset(0, 5).Value _
                        & r.Offset(0, 6).Value & r.Offset(0, 7).Value & r.Offset(0, 8).Value _
                        & r.Offset(0, 9).Value Like "*" & s & "*" Then
                        arr(i, 0) = r.Value
                        arr(i, 1) = r.Offset(0, 1).Value
                        arr(i, 2) = r.Offset(0, 2).Value
                        arr(i, 3) = r.Offset(0, 3).Value
                        arr(i, 4) = r.Offset(0, 4).Value
                        arr(i, 5) = r.Offset(0, 5).Value
                        arr(i, 6) = r.Offset(0, 6).Value
                        arr(i, 7) = r.Offset(0, 7).Value
                        arr(i, 8) = r.Offset(0, 8).Value
                        arr(i, 9) = r.Offset(0, 9).Value
                        arr(i, 10) = ws.Name
                        i = i + 1
                    End If
                Next r
            End With
        End If
    Next ws
    With Sheets(1)
        .Range("a5").Resize(i, 11).Value = arr
    End With
End Sub

[snasui]

ค้นหามาตาม Code นั้นย่อมคลิก Link ไม่ได้อยู่แล้วเพราะมันจะเอามาเฉพาะค่าเท่านั้น ไม่ได้นำ Link มาด้วย กรุณาเขียน Code สำหรับการเพิ่ม Link เข้ามาด้วย จากนั้นนำสิ่งที่ติดปัญหามาถามกันต่อครับ

[LomHoun]

คัดโฉนด2022 อัพเดท.xlsm

ผมได้แก้ Code แล้วแต่ยังติดบัคครับ

Code: Select all

Sub searchMultiplesheets()
    Dim r As Range, t As Range
    Dim ws As Worksheet, i As Integer, s As String
    With Sheets(1)
        s = .Range("c2").Value
        .Range("a5").Resize(.UsedRange.Rows.Count, _
        .UsedRange.Columns.Count).ClearContents
    End With
    For Each ws In Worksheets
        If ws.Name <> Sheets(1).Name Then
            With ws
                For Each r In .Range("a3", .Range("a" & .Rows.Count).End(xlUp))
                    If r.Value & r.Offset(0, 1).Value & r.Offset(0, 2).Value & _
                        r.Offset(0, 3).Value & r.Offset(0, 4).Value & r.Offset(0, 5).Value _
                        & r.Offset(0, 6).Value & r.Offset(0, 7).Value & r.Offset(0, 8).Value _
                        & r.Offset(0, 9).Value & r.Offset(0, 10).Value & r.Offset(0, 11).Value _
                        & r.Offset(0, 12).Value Like "*" & s & "*" Then
                            
                            With Sheets(1)
                                Set t = .Range("a" & .Rows.Count).End(xlUp).Offset(1, 0).Resize(1, 12)
                                r.Resize(1, 12).Copy t
                            End With
                            Application.CutCopyMode = False
                    End If
                Next r
            End With
        End If
    Next ws
End Sub

[snasui]

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

[snasui]

ตัวอย่างการปรับ Code ครับ

Code: Select all

Sub searchMultiplesheets()
    Dim r As Range, t As Range
    Dim ws As Worksheet, i As Integer, s As String
    Application.EnableEvents = False
    With Sheets(1)
        .Range("a5").Resize(10000, 12).UnMerge
        .Range("a5", .Range("a" & .Rows.Count).End(xlUp)).Resize(, 12).ClearContents
        s = .Range("c2").Value
        .Range("a5").Resize(.UsedRange.Rows.Count, _
        .UsedRange.Columns.Count).ClearContents
    End With
    For Each ws In Worksheets
        If ws.Name <> Sheets(1).Name Then
            With ws
                For Each r In .Range("a3", .Range("a" & .Rows.Count).End(xlUp))
                    If r.Value & r.Offset(0, 1).Value & r.Offset(0, 2).Value & _
                        r.Offset(0, 3).Value & r.Offset(0, 4).Value & r.Offset(0, 5).Value _
                        & r.Offset(0, 6).Value & r.Offset(0, 7).Value & r.Offset(0, 8).Value _
                        & r.Offset(0, 9).Value & r.Offset(0, 10).Value & r.Offset(0, 11).Value _
                        & r.Offset(0, 12).Value Like "*" & s & "*" Then
                        
                        With Sheets(1)
                            Set t = .Range("a" & .Rows.Count).End(xlUp).Offset(1, 0).Resize(1, 12)
                            r.Resize(1, 12).Copy t
                        End With
                        Application.CutCopyMode = False
                    End If
                Next r
            End With
        End If
    Next ws
    Application.EnableEvents = True
End Sub

[LomHoun]

ผมได้ทำการปรับแก้ Code แล้ว เมื่อทำการคนหา 4 ครั้งขึ้นไป การแสดงผลออกมาผิดพลาดครับ

[snasui]

ปรับแก้เป็นอะไรและผิดพลาดอย่างไร กรุณาอธิบายพร้อมแนบไฟล์ล่าสุดมาด้วยเสมอครับ

[LomHoun]

ผมได้ทำการปรับแก้ Code แล้ว เมื่อทำการคนหาหลายๆครั้ง การแสดงผลออกมาผิดพลาด และดึงข้อมูลมาแสดงไม่ครบครับครับ


ใน Sheet ที่ไม่มีข้อมูล ก็จะดึงเอาหัวข้อมาแสดง โดยที่ผมไม่ต้องการให้แสดงหัวข้อครับ

คัดโฉนด2022 อัพเดท.xlsm

Code: Select all

Sub searchMultiplesheets()
    Dim r As Range, t As Range
    Dim ws As Worksheet, i As Integer, s As String
    Application.EnableEvents = False
    With Sheets(1)
        .Range("a5").Resize(10000, 12).UnMerge
        .Range("a5", .Range("a" & .Rows.Count).End(xlUp)).Resize(, 12).ClearContents
        s = .Range("c2").Value
        .Range("a5").Resize(.UsedRange.Rows.Count, _
        .UsedRange.Columns.Count).ClearContents
    End With
    For Each ws In Worksheets
        If ws.Name <> Sheets(1).Name Then
            With ws
                For Each r In .Range("a3", .Range("a" & .Rows.Count).End(xlUp))
                    If r.Value & r.Offset(0, 1).Value & r.Offset(0, 2).Value & _
                        r.Offset(0, 3).Value & r.Offset(0, 4).Value & r.Offset(0, 5).Value _
                        & r.Offset(0, 6).Value & r.Offset(0, 7).Value & r.Offset(0, 8).Value _
                        & r.Offset(0, 9).Value & r.Offset(0, 10).Value & r.Offset(0, 11).Value _
                        & r.Offset(0, 12).Value Like "*" & s & "*" Then
                        
                        With Sheets(1)
                            Set t = .Range("a" & .Rows.Count).End(xlUp).Offset(1, 0).Resize(1, 12)
                            r.Resize(1, 12).Copy t
                        End With
                        Application.CutCopyMode = False
                    End If
                Next r
            End With
        End If
    Next ws
    Application.EnableEvents = True
End Sub

[snasui]

ตัวอย่างการปรับ Code ครับ

Code: Select all

Sub searchMultiplesheets()
    Dim r As Range, t As Range
    Dim ws As Worksheet, i As Integer, s As String
    Application.EnableEvents = False
    With Sheets(1)
        .Range("a5").Resize(10000, 12).UnMerge
        If .Range("a5").Value <> "" Then
            .Range("a5", .Range("a" & .Rows.Count).End(xlUp)).Resize(, 12).ClearContents
        End If
        s = .Range("c2").Value
        .Range("a5").Resize(.UsedRange.Rows.Count, _
            .UsedRange.Columns.Count).ClearContents
    End With
    For Each ws In Worksheets
        If ws.Name <> Sheets(1).Name Then
            With ws
                If .Range("l3").Value <> "" Then
                    For Each r In .Range("a3", .Range("a" & .Rows.Count).End(xlUp))
                        If r.Value & r.Offset(0, 1).Value & r.Offset(0, 2).Value & _
                            r.Offset(0, 3).Value & r.Offset(0, 4).Value & r.Offset(0, 5).Value _
                            & r.Offset(0, 6).Value & r.Offset(0, 7).Value & r.Offset(0, 8).Value _
                            & r.Offset(0, 9).Value & r.Offset(0, 10).Value & r.Offset(0, 11).Value _
                            & r.Offset(0, 12).Value Like "*" & s & "*" Then
                            
                            With Sheets(1)
                                Set t = .Range("a" & .Rows.Count).End(xlUp).Offset(1, 0).Resize(1, 12)
                                r.Resize(1, 12).Copy t
                            End With
                            Application.CutCopyMode = False
                        End If
                    Next r
                End If
            End With
        End If
    Next ws
    Application.EnableEvents = True
End Sub

[LomHoun]

ขอสอบถามเพิ่มเติมครับ ในการค้นหา เช่น ค้นหาคำว่า บึ่งกุ่ม ก็จะมีข้อมูลมาแสดงแค่ในแถวที่ A1 มีข้อมูลอยู่ ส่วนแถวที่ A1 ไม่มีข้อมูลก็จะไม่ถูกดึงมาแสดง จึงทำให้ค้นหาข้อมูลได้ไม่ครบ แบบนี้ควรแก้ยังไงครับ

ภาพนี้เป็นหน้าแสดงข้อมูลจากการค้นคำว่า บึงกุ่ม


ภาพนี้เป็นข้อมูลจริงที่อยู่ใน Sheet เมื่อเทียบกันดูแล้วจะเห็นว่าข้อมูลมาไม่ครบครับ

Code: Select all

Sub searchMultiplesheets()
    Dim r As Range, t As Range
    Dim ws As Worksheet, i As Integer, s As String
    Application.EnableEvents = False
    With Sheets(1)
        .Range("a5").Resize(10000, 12).UnMerge
        If .Range("a5").Value <> "" Then
            .Range("a5", .Range("a" & .Rows.Count).End(xlUp)).Resize(, 12).ClearContents
        End If
        s = .Range("c2").Value
        .Range("a5").Resize(.UsedRange.Rows.Count, _
            .UsedRange.Columns.Count).ClearContents
    End With
    For Each ws In Worksheets
        If ws.Name <> Sheets(1).Name Then
            With ws
                If .Range("l3").Value <> "" Then
                    For Each r In .Range("a3", .Range("a" & .Rows.Count).End(xlUp))
                        If r.Value & r.Offset(0, 1).Value & r.Offset(0, 2).Value & _
                            r.Offset(0, 3).Value & r.Offset(0, 4).Value & r.Offset(0, 5).Value _
                            & r.Offset(0, 6).Value & r.Offset(0, 7).Value & r.Offset(0, 8).Value _
                            & r.Offset(0, 9).Value & r.Offset(0, 10).Value & r.Offset(0, 11).Value _
                            & r.Offset(0, 12).Value Like "*" & s & "*" Then
                            
                            With Sheets(1)
                                Set t = .Range("a" & .Rows.Count).End(xlUp).Offset(1, 0).Resize(1, 12)
                                r.Resize(1, 12).Copy t
                            End With
                            Application.CutCopyMode = False
                        End If
                    Next r
                End If
            End With
        End If
    Next ws
    Application.EnableEvents = True
End Sub

[attachment=0]คัดโฉนด2022 อัพเดท.xlsm[/attachment]

[snasui]

ตัวอย่างการปรับ Code ครับ

Code: Select all

'Other code
With Sheets(1)
    Set t = .Cells(.Range("l" & .Rows.Count).End(xlUp).Offset(1, 0).Row, 1).Resize(1, 12)
    r.Resize(1, 12).Copy t
End With
'Other code

[LomHoun]

ได้แล้วครับ ขอบคุณมากเลยครับ