Richlilrich
06-13-2016, 07:59 AM
Hello I'm currently have a workbook with over 2000 lines of information.
What I'm trying to do is to search for a number in the B Column and copy the results to A2 in sheet2 going down A3 A4 A5 as there is numerious results.
The code below searchs copies and pastes but stops at the first one it finds and doesn't carry on for the rest.
Can anyone help please?
Sub Button5_click ()
Dim rId As Range, celS As Range, celT As Range
Dim wS As Worksheet, wT As Worksheet
Dim sId As String
Set wS = Worksheets("date1")
Set wT = Worksheets("Sheet1")
Set celT = wT.Range("A6")
Do
sId = InputBox("Enter week no")
If Len(sId) = 0 Then Exit Sub
Set rId = wS.Range("B3")
Set rId = wS.Range(rId, wS.Cells(wS.Rows.Count, rId.Column).End(xlUp)) 'rest of data
Set celS = rId.Find(sId, , xlValues, xlWhole, , , False)
If Not celS Is Nothing Then
Set celS = Intersect(wS.Columns("C:C"), celS.EntireRow)
If Not IsEmpty(celT) Then
Set celT = wT.Cells(wT.Rows.Count, celT.Column).End(xlUp).Offset(1)
End If
celT.Value = celS.Value
End If
Loop Until Len(sId) = 0
End Sub
What I'm trying to do is to search for a number in the B Column and copy the results to A2 in sheet2 going down A3 A4 A5 as there is numerious results.
The code below searchs copies and pastes but stops at the first one it finds and doesn't carry on for the rest.
Can anyone help please?
Sub Button5_click ()
Dim rId As Range, celS As Range, celT As Range
Dim wS As Worksheet, wT As Worksheet
Dim sId As String
Set wS = Worksheets("date1")
Set wT = Worksheets("Sheet1")
Set celT = wT.Range("A6")
Do
sId = InputBox("Enter week no")
If Len(sId) = 0 Then Exit Sub
Set rId = wS.Range("B3")
Set rId = wS.Range(rId, wS.Cells(wS.Rows.Count, rId.Column).End(xlUp)) 'rest of data
Set celS = rId.Find(sId, , xlValues, xlWhole, , , False)
If Not celS Is Nothing Then
Set celS = Intersect(wS.Columns("C:C"), celS.EntireRow)
If Not IsEmpty(celT) Then
Set celT = wT.Cells(wT.Rows.Count, celT.Column).End(xlUp).Offset(1)
End If
celT.Value = celS.Value
End If
Loop Until Len(sId) = 0
End Sub