ค้นหารายการที่ต้องการและคัดลอกมาอัตโนมัติ

Totem · #1

เรียนอาจารย์และเพื่อนสมาชิก

ต้องการให้คัดลอกข้อมูล ซึ่งไม่สามารถคัดลอกข้อมูลในส่วนที่ค้นหามาได้ทั้งหมด ให้มาวางต่อกันตั้งแต่ H1 : L3 ให้ข้อมูลที่ได้จากตารางทางซ้ายเรียงจากบนลงล่าง - ถ้าหากเกิดช่องว่าง เช่น ช่อง D2 เป็นช่องว่างให้คัดลอกตั้งแต่ B2 : F2 ไปวางไว้ที่ H1 : L1 เป็นต้น ครับ ช่วยดู CODE

Code: Select all

Sub Foundcopy()
    Dim nRange As Range, aCell As Range, bCell As Range
    Dim SearchString As String, FoundAt As String
    Dim ws As Worksheet
    Dim ExitLoop As Boolean
    

    On Error GoTo Err

    Set ws = Worksheets("sheet1")

    
    Set nRange = ws.Range("B2:F11")

    
    Name = Application.InputBox("ãÊè¢éÍÁÙÅ·ÕèµéÍ§¡ÒÃ¤é¹ËÒ", "*")

    Set aCell = nRange.Find(What:=Name, LookIn:=xlValues, _
                LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
                MatchCase:=False, SearchFormat:=False)
                
    If Not aCell Is Nothing Then
        Set bCell = aCell
        FoundAt = aCell.Address
        Do While ExitLoop = False
            Set aCell = nRange.FindNext(After:=aCell)

            If Not aCell Is Nothing Then
                If aCell.Address = bCell.Address Then Exit Do
                FoundAt = FoundAt & ", " & aCell.Address
            Else
                ExitLoop = True
            End If
        Loop
    Else
        MsgBox SearchString & "äÁè¾º¢éÍÁÙÅ"
    End If

    MsgBox "µÓáË¹è§·Õè¾º: " & FoundAt
     
        Range(FoundAt).Select
        
        Range(Selection, Selection.End(xlToRight)).Copy
        
        Range("H1").PasteSpecial xlPasteValuesAndNumberFormats
        Application.CutCopyMode = False
    
    Exit Sub
    
Err:
    MsgBox Err.Description
    
End Sub

ตรงนี้ครับ

Code: Select all

        Range(FoundAt).Select
        
        Range(Selection, Selection.End(xlToRight)).Copy

ผมลองปรับดูแล้วยังไม่สำเร็จครับ

snasui · #2

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

Code: Select all

Sub Foundcopy()
    Dim nRange As Range, aCell As Range, bCell As Range
    Dim SearchString As String, FoundAt As String
    Dim ws As Worksheet
    Dim ExitLoop As Boolean
    Dim r As Range, rString As String

    'Other code

   MsgBox "ตำแหน่งที่พบ: " & FoundAt

   For Each r In Range(FoundAt)
       rString = rString & "," & r.Resize(, 5).Address
   Next r

   Range(Mid(rString, 2)).Copy

   Range("H1").PasteSpecial xlPasteValuesAndNumberFormats
   Application.CutCopyMode = False

   Exit Sub
    
Err:
    MsgBox Err.Description
    
End Sub

Totem · #3

snasui wrote:

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

Code: Select all

Sub Foundcopy()
    Dim nRange As Range, aCell As Range, bCell As Range
    Dim SearchString As String, FoundAt As String
    Dim ws As Worksheet
    Dim ExitLoop As Boolean
    Dim r As Range, rString As String

    'Other code

   MsgBox "ตำแหน่งที่พบ: " & FoundAt

   For Each r In Range(FoundAt)
       rString = rString & "," & r.Resize(, 5).Address
   Next r

   Range(Mid(rString, 2)).Copy

   Range("H1").PasteSpecial xlPasteValuesAndNumberFormats
   Application.CutCopyMode = False

   Exit Sub
    
Err:
    MsgBox Err.Description
    
End Sub

ปรับ code แล้ว ได้ตามต้องการครับ ขอบคุณครับอาจารย์

Totem · #4

ถ้าหาค้นหาแล้วพบข้อมูลในเซลใดๆ ต้องการให้คัดลอกทั้งแถวนั้นๆ จะปรับ code อย่างไรครับ

Code: Select all

Sub Foundcopy()
    Dim nRange As Range, aCell As Range, bCell As Range
    Dim SearchString As String, FoundAt As String
    Dim ws As Worksheet
    Dim ExitLoop As Boolean
    Dim r As Range, rString As String
    Dim lastRow As Long
    
    On Error GoTo Err

    Set ws = Worksheets("sheet1")


    lastRow = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
    
    Set oRange = ws.Range("A2:F" & lastRow)

    
    Name = Application.InputBox("ãÊè¢éÍÁÙÅ·ÕèµéÍ§¡ÒÃ¤é¹ËÒ", "*")

    Set aCell = nRange.Find(What:=Name, LookIn:=xlValues, _
                LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
                MatchCase:=False, SearchFormat:=False)
                
    If Not aCell Is Nothing Then
        Set bCell = aCell
        FoundAt = aCell.Address
        Do While ExitLoop = False
            Set aCell = nRange.FindNext(After:=aCell)

            If Not aCell Is Nothing Then
                If aCell.Address = bCell.Address Then Exit Do
                FoundAt = FoundAt & ", " & aCell.Address
            Else
                ExitLoop = True
            End If
        Loop
    Else
        MsgBox SearchString & "äÁè¾º¢éÍÁÙÅ"
    End If

    MsgBox "µÓáË¹è§·Õè¾º: " & FoundAt
     
   For Each r In Range(FoundAt)
             
                
       rString = rString & "," & r.Resize(, 5).Address
   Next r
                     
            Range(Mid(rString, 2)).Copy

            Range("H1").PasteSpecial xlPasteValuesAndNumberFormats
            Application.CutCopyMode = False
    
    Exit Sub
    
Err:
    MsgBox Err.Description
    
End Sub

ขอบคุณครับ

Foundcopy one.xlsm

snasui · #5

ที่เขียนมาเองแล้วติดปัญหาอย่างไร หรือติดปัญหาที่บรรทัดใดครับ

Totem · #6

Code: Select all

Sub Foundcopy()
    Dim nRange As Range, aCell As Range, bCell As Range
    Dim SearchString As String, FoundAt As String
    Dim ws As Worksheet
    Dim ExitLoop As Boolean
    Dim r As Range, rString As String
    Dim lastRow As Long
    
    On Error GoTo Err

    Set ws = Worksheets("sheet1")


    lastRow = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
    
    Set nRange = ws.Range("A2:F" & lastRow)

    
    Name = Application.InputBox("ãÊè¢éÍÁÙÅ·ÕèµéÍ§¡ÒÃ¤é¹ËÒ", "*")

     
    Set aCell = nRange.Find(What:=Name, LookIn:=xlValues, _
                LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
                MatchCase:=False, SearchFormat:=False)
                
    If Not aCell Is Nothing Then
        Set bCell = aCell
        FoundAt = aCell.Address
        Do While ExitLoop = False
            Set aCell = nRange.FindNext(After:=aCell)

            If Not aCell Is Nothing Then
                If aCell.Address = bCell.Address Then Exit Do
                FoundAt = FoundAt & ", " & aCell.Address
            Else
                ExitLoop = True
            End If
        Loop
    Else
        MsgBox SearchString & "äÁè¾º¢éÍÁÙÅ"
    End If

    MsgBox "µÓáË¹è§·Õè¾º: " & FoundAt
    
     
   For Each r In Range(FoundAt)
             
       rString = rString & "," & r.Resize(1, 6).Address
       
   Next r
                     
            Range(Mid(rString, 2)).Copy

            Range("H1").PasteSpecial xlPasteValuesAndNumberFormats
            Application.CutCopyMode = False
    
    Exit Sub
    
Err:
    MsgBox Err.Description
    
End Sub

ปัญหาคือ ถ้าผมค้นหาข้อความหรือตัวเลขได้แล้วให้ คัดลอกมาทั้งแถว ยกตัวอย่าง

ค้นหา a1 มีในช่อง a2 , d5 , b8 แล้ว ให้คัดลอก a2:f2 , a5:f5 , a8:f8 มาวางไว้ที่ h1 ตามลำดับที่แสดงไว้ใน
ไฟล์แนบครับ

จะปรับอย่างไรครับ

Code: Select all

r.Resize(1, 6).Address

คัดลอกมาได้แต่ไม่ได้ตามที่ต้องการครับ

Foundcopy 2.xlsm

niwat2811 · #7

Code: Select all

Sub test()
Dim r As Range
Name = Application.InputBox("ãÊè¢éÍÁÙÅ·ÕèµéÍ§¡ÒÃ¤é¹ËÒ", "*")
For Each r In Range("A2:F11")
    If r.Value = Name Then
        r.End(xlToLeft).Resize(1, 6).Copy Range("H" & Rows.Count).End(xlUp).Offset(1, 0)
     End If
Next r
Range("H1").Resize(1, 6).Delete Shift:=xlUp
End Sub

ลองแบบนี้ว่าใช้ได้ตามต้องการไหมครับ

Totem · #8

niwat2811 wrote:

Code: Select all

Sub test()
Dim r As Range
Name = Application.InputBox("ãÊè¢éÍÁÙÅ·ÕèµéÍ§¡ÒÃ¤é¹ËÒ", "*")
For Each r In Range("A2:F11")
    If r.Value = Name Then
        r.End(xlToLeft).Resize(1, 6).Copy Range("H" & Rows.Count).End(xlUp).Offset(1, 0)
     End If
Next r
Range("H1").Resize(1, 6).Delete Shift:=xlUp
End Sub

ลองแบบนี้ว่าใช้ได้ตามต้องการไหมครับ

ลองปรับแล้ว ได้ผลตามต้องการครับ ขอบคุณครับ คุณ niwat2811

Snasui Excel Forum

File Anatomy Add-in: แก้ปัญหาไฟล์ Excel ช้า แฮงก์ และไม่เสถียร อย่างมืออาชีพ

ค้นหารายการที่ต้องการและคัดลอกมาอัตโนมัติ

ค้นหารายการที่ต้องการและคัดลอกมาอัตโนมัติ

Re: ค้นหารายการที่ต้องการและคัดลอกมาอัตโนมัติ

Re: ค้นหารายการที่ต้องการและคัดลอกมาอัตโนมัติ

Re: ค้นหารายการที่ต้องการและคัดลอกมาอัตโนมัติ

Re: ค้นหารายการที่ต้องการและคัดลอกมาอัตโนมัติ

Re: ค้นหารายการที่ต้องการและคัดลอกมาอัตโนมัติ

Re: ค้นหารายการที่ต้องการและคัดลอกมาอัตโนมัติ

Re: ค้นหารายการที่ต้องการและคัดลอกมาอัตโนมัติ