copy paste specific content

[excelnoobhere]

I'm looking for a code that will copy certain columns and paste them into a new sheets that will be created based on cell value.
for example lets say I have a huge list of data in cell A contain
A
5555-01-120-121
5555-01-120-123
5555-02-120-255
5555-05-150-220

I would like to be able to search through all of an and if A contain -01- then that gets copied that row's columns (A,B,O) into a new sheet columns (A,B,C) titled -01-, and if it contains -02- then creates a new sheet and does the same and so on for -05-

basically I want to split these data based on the value I have in red

how can I go about this?

any help would be much appreciated

 

[Fluff]

How about

Sub excelnoobhere()
   Dim Cl As Range
   Dim Uniq As String
   Dim Ky As Variant
   Dim Ws As Worksheet
   
   Set Ws = Sheets("[COLOR=#ff0000]All[/COLOR]")
   With CreateObject("scripting.dictionary")
      For Each Cl In Ws.Range("A2", Ws.Range("A" & Rows.Count).End(xlUp))
         Uniq = Mid(Cl, 5, 4)
         .Item(Uniq) = Empty
      Next Cl
      For Each Ky In .Keys
         Ws.Range("A1:O1").AutoFilter 1, "*" & Ky & "*"
         Sheets.Add(, Sheets(Sheets.Count)).Name = Ky
         Intersect(Ws.AutoFilter.Range.EntireRow, Ws.Range("A:B,O:O")).Copy Range("A1")
      Next Ky
      Ws.AutoFilterMode = False
   End With
End Sub

Change sheet name in red to suit

 

[excelnoobhere]

How about

Sub excelnoobhere()
   Dim Cl As Range
   Dim Uniq As String
   Dim Ky As Variant
   Dim Ws As Worksheet
   
   Set Ws = Sheets("[COLOR=#ff0000]All[/COLOR]")
   With CreateObject("scripting.dictionary")
      For Each Cl In Ws.Range("A2", Ws.Range("A" & Rows.Count).End(xlUp))
         Uniq = Mid(Cl, 5, 4)
         .Item(Uniq) = Empty
      Next Cl
      For Each Ky In .Keys
         Ws.Range("A1:O1").AutoFilter 1, "*" & Ky & "*"
         Sheets.Add(, Sheets(Sheets.Count)).Name = Ky
         Intersect(Ws.AutoFilter.Range.EntireRow, Ws.Range("A:B,O:O")).Copy Range("A1")
      Next Ky
      Ws.AutoFilterMode = False
   End With
End Sub

Change sheet name in red to suit

i get an error when running

run-time error '9'

subscribe out of range

my code....
' Macro1 Macro
'


Sub CopyCode()


Dim Cl As Range
Dim Uniq As String
Dim Ky As Variant
Dim Ws As Worksheet

Set Ws = Sheets("MASTER")
With CreateObject("scripting.dictionary")
For Each Cl In Ws.Range("A2", Ws.Range("A" & Rows.Count).End(xlUp))
Uniq = Mid(Cl, 5, 4)
.Item(Uniq) = Empty
Next Cl
For Each Ky In .Keys
Ws.Range("A1:O1").AutoFilter 1, "*" & Ky & "*"
Sheets.Add(, Sheets(Sheets.Count)).Name = Ky
Intersect(Ws.AutoFilter.Range.EntireRow, Ws.Range("A:B,O:O")).Copy Range("A1")
Next Ky
Ws.AutoFilterMode = False
End With
End Sub

 

[Fluff]

If the error is on this line

Set Ws = Sheets("MASTER")

then you don't have a sheet called Master in the activeworkbook.
Check for leading/trailing spaces.

 

[excelnoobhere]

If the error is on this line

Set Ws = Sheets("MASTER")

then you don't have a sheet called Master in the activeworkbook.
Check for leading/trailing spaces.

error is not there, it goes through the loops of reading all of A however it gets an error right when it creates the new sheet.
it creates an empty sheet and it just stops ther

 

[Fluff]

Add this line as shown

      For Each Ky In .Keys
         MsgBox "|" & Ky & "|"
         Ws.Range("A1:O1").AutoFilter 1, "*" & Ky & "*"

What does the msgbox say just before it fails?

 

[excelnoobhere]

Add this line as shown

      For Each Ky In .Keys
         MsgBox "|" & Ky & "|"
         Ws.Range("A1:O1").AutoFilter 1, "*" & Ky & "*"

What does the msgbox say just before it fails?

the message box just says " || "

 

[Kenneth Hobson]

Please paste code between code tags. Click the # icon on reply toolbar to insert tags.

With cursor in the routine in the VBE, press F8 to execute each line to see which is causing the problem.

It could be that the activeworkbook does not contain a sheet named Master. It could be that your filter range did not start in row1. It could be that a sheet with name of Ky's value already exists, etc...

 

[Fluff]

Do you have blank cells in col A?
If so try

Sub excelnoobhere()
   Dim Cl As Range
   Dim Uniq As String
   Dim Ky As Variant
   Dim Ws As Worksheet
   
   Set Ws = Sheets("Master")
   With CreateObject("scripting.dictionary")
      For Each Cl In Ws.Range("A2", Ws.Range("A" & Rows.Count).End(xlUp))
         Uniq = Mid(Cl, 5, 4)
         If Uniq <> "" Then .Item(Uniq) = Empty
      Next Cl
      For Each Ky In .Keys
         Ws.Range("A1:O1").AutoFilter 1, "*" & Ky & "*"
         Sheets.Add(, Sheets(Sheets.Count)).Name = Ky
         Intersect(Ws.AutoFilter.Range.EntireRow, Ws.Range("A:B,O:O")).Copy Range("A1")
      Next Ky
      Ws.AutoFilterMode = False
   End With
End Sub

 

[excelnoobhere]

[CODE][CODE]

[/CODE][/CODE]

Do you have blank cells in col A?
If so try

Sub excelnoobhere()
   Dim Cl As Range
   Dim Uniq As String
   Dim Ky As Variant
   Dim Ws As Worksheet
   
   Set Ws = Sheets("Master")
   With CreateObject("scripting.dictionary")
      For Each Cl In Ws.Range("A2", Ws.Range("A" & Rows.Count).End(xlUp))
         Uniq = Mid(Cl, 5, 4)
         If Uniq <> "" Then .Item(Uniq) = Empty
      Next Cl
      For Each Ky In .Keys
         Ws.Range("A1:O1").AutoFilter 1, "*" & Ky & "*"
         Sheets.Add(, Sheets(Sheets.Count)).Name = Ky
         Intersect(Ws.AutoFilter.Range.EntireRow, Ws.Range("A:B,O:O")).Copy Range("A1")
      Next Ky
      Ws.AutoFilterMode = False
   End With
End Sub

still not working

i have uploaded a sample of my excel sheet here if you'd like to give it a try

thanx in advance

https://www.dropbox.com/s/6bj17payiemet39/test.xlsx?dl=0