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

 

[vcoolio]

Hello Dibyendu,

Try the following code in a copy of your workbook first:-

Sub TransferData()

    Dim IdSrch As String
    Dim lr As Long

IdSrch = InputBox("Please enter the ID to search.")
If IdSrch = vbNullString Then Exit Sub

Application.ScreenUpdating = False

Sheet2.UsedRange.Offset(1).ClearContents

With Sheet1.[A1].CurrentRegion
     lr = Sheet1.Range("A" & Rows.Count).End(xlUp).Row
     .AutoFilter 4, IdSrch
     Union(Range("H2:I" & lr), Range("BG2:BT" & lr)).Copy
     Sheet2.Range("A" & Rows.Count).End(3)(2).PasteSpecial xlValues
     .AutoFilter
End With
     
Application.CutCopyMode = False
Application.ScreenUpdating = True

End Sub

I've used the sheet codes instead of the sheet names so I'm assuming that your sheet "Records" is Sheet1 and sheet "Summary" is Sheet2.

I hope that this helps.

Cheerio,
vcoolio.

 

[dibyendu]

The Record Sheet is password procted.This code on execution gives error"1004" probably "With Worksheets("Records").[A1].CurrentRegion"

Hello Dibyendu,

Try the following code in a copy of your workbook first:-

Sub TransferData()

    Dim IdSrch As String
    Dim lr As Long

IdSrch = InputBox("Please enter the ID to search.")
If IdSrch = vbNullString Then Exit Sub

Application.ScreenUpdating = False

Sheet2.UsedRange.Offset(1).ClearContents

With Sheet1.[A1].CurrentRegion
     lr = Sheet1.Range("A" & Rows.Count).End(xlUp).Row
     .AutoFilter 4, IdSrch
     Union(Range("H2:I" & lr), Range("BG2:BT" & lr)).Copy
     Sheet2.Range("A" & Rows.Count).End(3)(2).PasteSpecial xlValues
     .AutoFilter
End With
     
Application.CutCopyMode = False
Application.ScreenUpdating = True

End Sub

I've used the sheet codes instead of the sheet names so I'm assuming that your sheet "Records" is Sheet1 and sheet "Summary" is Sheet2.

I hope that this helps.

Cheerio,
vcoolio.

 

[vcoolio]

You'll have to un-protect the sheet as whatever a User may try to do while its protected won't work.

Furthermore, it would be best if you uploaded a sample of your actual workbook to a free file sharing site (such as Drop Box) and then post the link to your file back here. It will then be easier for us to determine where a problem may arise. Please use dummy data in the sample.

Following is a link to a sample file that I prepared based on your opening explanation. It is unprotected and you'll see that it works as per your explanation:-

http://ge.tt/9jU4ndm2

Cheerio,
vcoolio.

 

[dibyendu]

Following is a link to a sample file
https://drive.google.com/file/d/0B3mCr8NTh3hRaGtqajJjdTdiR00/view?usp=sharing

Thanks
Dibyendu

 

[vcoolio]

Could you please upload your excel file to a file sharing site, as mentioned in post #4 , such as Drop Box or Ge.tt (as per the sample I supplied) as the one you supplied will not permit us to work with your data or test any coding.

Cheerio,
vcoolio.

 

[dibyendu]

https://www.dropbox.com/sh/8nrvbfh7tbjff9j/AAC3BLzx1Y9zPpuAZxfzjUk-a?dl=0
"or"
http://ge.tt/2Aca4fm2

Please find the attachment from the link given above.

Thanks
Dibyendu

 

[vcoolio]

Hello Dibyendu,

Following is a revised code:-

Sub TransferData()

    Dim IdSrch As String
    Dim lr As Long
   [COLOR=#ff0000] Dim ws As Worksheet, ws1 As Worksheet

Set ws = Sheets("Summary")
Set ws1 = Sheets("Records")[/COLOR]
IdSrch = InputBox("Please enter the ID to search.")
If IdSrch = vbNullString Then Exit Sub

Application.ScreenUpdating = False

[COLOR=#ff0000]ws.[/COLOR]UsedRange.Offset(1).ClearContents

With [COLOR=#ff0000]ws1.[A4][/COLOR].CurrentRegion
     lr = [COLOR=#ff0000]ws1[/COLOR].Range("A" & Rows.Count).End(xlUp).Row
     .AutoFilter 4, IdSrch
     Union(Range("[COLOR=#ff0000]H5[/COLOR]:I" & lr), Range("[COLOR=#ff0000]BG5[/COLOR]:BT" & lr)).Copy
     [COLOR=#ff0000]ws.[/COLOR]Range("A" & Rows.Count).End(3)(2).PasteSpecial xlValues
     .AutoFilter
End With
     
Application.CutCopyMode = False
Application.ScreenUpdating = True

End Sub

You'll note the additions/alterations are in red font.
The code that you altered in the code module in the sample had spelling errors which contributed to the error messages that you were receiving.
It should now work as required.

I hope that this helps.

Cheerio,
vcoolio.

 

[dibyendu]

Thanks for the correction and kind help....

Dibyendu

 

[vcoolio]

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

I'll leave it to you to mark the thread as solved.

Cheerio,
vcoolio.