Copy Rows With Same Value into a new Worksheet

[tnederlof]

Hey right now I have a huge excel sheet with like 250 columns and
there are about 250 rows but I need the macro to go up to 1500 because
I will be getting more data. In the column "i" I have different
strings such as "Burger King". I need a macro that will copy every row
in the sheet that is the value of Burger King in "i" for example to
its own sheet entitled that value. Can someone help me out please? I
tried a few things I found by searching but they didn't work.

Thank you very much!

 

[Gord Dibben]

Data>Filter>Autofilter.

Filter for Burger King on column I.

Copy and paste the results to a Burger King sheet.

If you need code for copying, adding a sheet and pasting try Ron de Bruin's site
for methods.

http://www.rondebruin.nl/copy5.htm

More on Copying, Pasting and Merging at Ron's Excel Tips page.

See link when on the above page.


Gord Dibben MS Excel MVP

 

[tnederlof]

Data>Filter>Autofilter.

Filter for Burger King on column I.

Copy and paste the results to a Burger King sheet.

If you need code for copying, adding a sheet and pasting try Ron de Bruin's site
for methods.

http://www.rondebruin.nl/copy5.htm

More on Copying, Pasting and Merging at Ron's Excel Tips page.

See link when on the above page.

Hmm I tried those and they would only copy the first row and that is
it.

 

[Ron de Bruin]

Hi

It use this now
If there is a empty row it not filter all data when you use the AutoFilter example

Set rng = WS.Range("A1").CurrentRegion '<<< Change

You can change it to

Set rng = WS.Range("A1:IV5000")

 

[tnederlof]

I just says subscript out of range. Could someone post the script
modifed for burger king on a page called "rawdata" and so that the
value is found in column i? Thanks

 

[Ron de Bruin]

Try this

Sub Copy_With_AutoFilter1()
Dim WS As Worksheet
Dim WSNew As Worksheet
Dim rng As Range
Dim rng2 As Range
Dim Str As String

Set WS = Sheets("rawdata") '<<< Change
'A1 is the top left cell of your filter range and the header of the first column
Set rng = WS.Range("A1:IV5000")

Str = "Burger King" '<<< Change

'Close AutoFilter first
WS.AutoFilterMode = False

'This example filter on the first column in the range (change the field if needed)
'I change the 1 to the I column = 9
rng.AutoFilter Field:=9, Criteria1:=Str

Set WSNew = Worksheets.Add

WS.AutoFilter.Range.Copy
With WSNew.Range("A1")
' Paste:=8 will copy the columnwidth in Excel 2000 and higher
.PasteSpecial Paste:=8
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
Application.CutCopyMode = False
.Select
End With

' 'If you want to delete the rows in WS that you copy use this also
' With WS.AutoFilter.Range
' On Error Resume Next
' Set rng2 = .Offset(1, 0).Resize(.Rows.Count - 1, .Columns.Count) _
' .SpecialCells(xlCellTypeVisible)
' On Error GoTo 0
' If Not rng2 Is Nothing Then rng2.EntireRow.Delete
' End With

WS.AutoFilterMode = False

On Error Resume Next
WSNew.Name = Str
If Err.Number > 0 Then
MsgBox "Change the name of : " & WSNew.Name & " manually"
Err.Clear
End If
On Error GoTo 0
End Sub

 

[tnederlof]

Still says subscript out of range

Try this

Sub Copy_With_AutoFilter1()
Dim WS As Worksheet
Dim WSNew As Worksheet
Dim rng As Range
Dim rng2 As Range
Dim Str As String

Set WS = Sheets("rawdata") '<<< Change
'A1 is the top left cell of your filter range and the header of the first column
Set rng = WS.Range("A1:IV5000")

Str = "Burger King" '<<< Change

'Close AutoFilter first
WS.AutoFilterMode = False

'This example filter on the first column in the range (change the field if needed)
'I change the 1 to the I column = 9
rng.AutoFilter Field:=9, Criteria1:=Str

Set WSNew = Worksheets.Add

WS.AutoFilter.Range.Copy
With WSNew.Range("A1")
' Paste:=8 will copy the columnwidth in Excel 2000 and higher
.PasteSpecial Paste:=8
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
Application.CutCopyMode = False
.Select
End With

' 'If you want to delete the rows in WS that you copy use this also
' With WS.AutoFilter.Range
' On Error Resume Next
' Set rng2 = .Offset(1, 0).Resize(.Rows.Count - 1, .Columns.Count) _
' .SpecialCells(xlCellTypeVisible)
' On Error GoTo 0
' If Not rng2 Is Nothing Then rng2.EntireRow.Delete
' End With

WS.AutoFilterMode = False

On Error Resume Next
WSNew.Name = Str
If Err.Number > 0 Then
MsgBox "Change the name of : " & WSNew.Name & " manually"
Err.Clear
End If
On Error GoTo 0
End Sub

 

[Ron de Bruin]

Maybe you have a space after your sheet name

Set WS = Sheets("rawdata") '<<< Change