Copy rows from activesheet and create and paste in new sheet.

[Closed]
Report
Posts
1
Registration date
Tuesday November 25, 2014
Status
Member
Last seen
November 25, 2014
-
 heyxarno -
Hey guys

I have a workbook with +-5000 rows of rooms in different buildings. I want use the column BUILDING_CODE and copy all the rooms that have the same building code into their own sheet.

I'm fairly new to VBA, so would appreciate the help.

Kind regards

1 reply

This should work - it searches via row then pastes the row into sheet 2, if you want to change where the data is sent just change the sheet number.

If someone knows how to make this code delete the source info id really appreciate it!


Sub customcopy()
Dim strsearch As String, lastline As Integer, tocopy As Integer

strsearch = CStr(InputBox("enter the string to search for"))
lastline = Range("A65536").End(xlUp).Row
j = 1

For i = 1 To lastline
For Each c In Range("B" & i & ":Z" & i)
If InStr(c.Text, strsearch) Then
tocopy = 1
End If
Next c
If tocopy = 1 Then
Rows(i).Copy Destination:=Sheets(2).Rows(j)
j = j + 1
End If
tocopy = 0
Next i

End Sub
1
Thank you

A few words of thanks would be greatly appreciated. Add comment

CCM 2821 users have said thank you to us this month

Hey Geo_Cha

Thanks so much for the help. I've used your code and modified it a bit so that when the string that will it typed into the message box creates a new sheet named after that string. It looks like this.

Sub customcopy()

Dim strsearch As String, lastline As Integer, tocopy As Integer, ws As Worksheet
Dim CurrSht As Integer

Set ws = ActiveSheet


strsearch = CStr(InputBox("enter the string to search for"))

lastline = Range("A65536").End(xlUp).Row

j = 1


CurrSht = ActiveSheet.Index

Worksheets.Add After:=Worksheets(CurrSht)

ActiveSheet.Name = strsearch



Call FirstSheet 'this function just calls back the active sheet so that the macro can sort

from that sheet



For i = 1 To lastline

For Each c In Range("B" & i & ":Z" & i)

If InStr(c.Text, strsearch) Then

tocopy = 1

End If

Next c

If tocopy = 1 Then

Rows(i).Copy Destination:=Sheets(strsearch).Rows(j)

j = j + 1

End If

tocopy = 0

Next i



End Sub