Snasui Excel Forum

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

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: 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

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

Code: Select all

r.Resize(1, 6).Address

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