Copy cells of row containing string to different worksheet in vba

[dibyendu]

I have two worksheets named as "Records" and "Summary". In column D of worksheet "Records" there are registration number of different subjects (format "0000/2017, 000/2017, 00/2017, 0/2017, 000/2016, etc.).The occurrence of registration number of particular subject (which is unique number) is multiple in column D. Now, I need a VBA code which when run asked for registration number in the "pop-up" input box and then it will search for that particular registration number in column D of worksheet "Records".Thereafter, it will copy cell content of column "H","I","BG:BT" of the row containing the registration number.Now, the copied content will be paste in worksheet "Summary" in column "A","B","C","D".....(First row need to remain empty for HEADING). The above process should continue till all the occurence of multiple registration number in column D of worksheet "Records" and paste it in worksheet "Summary" in the next available row.When the macro is again runned, all the content of worksheet "Summary" needs to be cleared off.

Hopefully this is understandable, if anyone can help me or has any questions to help clarify please let me know. I have tried with the following code but it gives "run-time error 9".Sub FindNext_CopyX_Data() Application.ScreenUpdating = False Sheets("Summary").Columns("A:Q").ClearContents Dim ws1 As Worksheet, ws2 As Worksheet Dim AllCells As Range, Cell As Range Dim n&, Regno As String Set ws1 = Sheets("Records"): Set ws2 = Sheets("Summary"): Regno = InputBox("Which Registration Number ?"): ws1.Select 'added select sheet1 Set AllCells = ws1.Range("D1", Range("G65536").End(xlUp)) n = ws2.Range("A" & Rows.Count).End(xlUp).Row + 1 For Each Cell In AllCells With Cell If Cell = Regno Then Cell.EntireRow.Copy Destination:=ws2.Cells(n, 1): n = n + 1 End If End With Next Cell ws2.Select: Set ws1 = Nothing: Set ws2 = Nothing: Set AllCells = Nothing Range("A:G").EntireColumn.Delete Range("J:BE").EntireColumn.Delete Range("BU:BX").EntireColumn.Delete Application.ScreenUpdating = True End Sub

 

[dibyendu]

The code runs fine but when I enter an "ID" which is not present in the column, then it copies entire sheet(whereas, it should copy nothing if matching not found).

 

[vcoolio]

Hello Dibyendu,

Qualifying that a last row exists should sort that out for you. Following is the adjusted code:-

Sub TransferData()

    Dim IdSrch As String
    Dim lr As Long
    Dim ws As Worksheet, ws1 As Worksheet
    
Set ws = Sheets("Summary")
Set ws1 = Sheets("Records")
IdSrch = InputBox("Please enter the ID to search.")
If IdSrch = vbNullString Then Exit Sub

Application.ScreenUpdating = False

ws.UsedRange.Offset(1).ClearContents

With ws1.[A4].CurrentRegion
     .AutoFilter 4, IdSrch
     lr = ws1.Range("A" & Rows.Count).End(xlUp).Row
     If lr > 4 Then
     Union(Range("H5:I" & lr), Range("BG5:BT" & lr)).Copy
     ws.Range("A" & Rows.Count).End(3)(2).PasteSpecial xlValues
     End If
    .AutoFilter
End With

Application.CutCopyMode = False
Application.ScreenUpdating = True

End Sub

I hope that this helps.

Cheerio,
vcoolio.

 

[dibyendu]

Thanks for you valuable inputs and time. The code runs perfectly.
You made the thread completed.
Thanksgiving
Dibyendu Sharma

 

[vcoolio]

You're welcome Dibyendu. Glad that I was able to help.

All the best.

Cheerio,
vcoolio.