Template generator and data sorting

[excelnoobhere]

I have the following data excel code that looks at a sheet of data and sorts the data based on a number and copies it to a new template sheet.

A B C............
Line: 51106-02 AB ZONE
51106-02-904-601 Some info Some Info
51106-02-904-601 Some info Some Info
51106-03-904-601 Some info Some Info
Line: 51106-05 AD ZONE
51106-05-904-601 Some info Some Info
51106-05-904-601 Some info Some Info

Right now the codes searches through column A and based on if its an -02- or -03- it copies certain rows and transfer it to a new template.
currently it ignores the the row that starts with "Line"

I want to be able to be able to extract the "AB " and place it at each newly created template at cell A1 and so on for AD

also now it titles each sheet with -02 -03 -04-.... Is thee a way to title it with AD ..AB..

 

[DanteAmor]

You can put your code to make the change

 

[excelnoobhere]

You can put your code to make the change

Sub CopyToNewTempSheet()

        'define varibales
   Dim Cl As Range
   Dim Uniq As String
   Dim Ky As Variant
   Dim ws As Worksheet


   
   Set ws = Sheets("Data")
   ws.AutoFilterMode = False
   With CreateObject("scripting.dictionary")
      For Each Cl In ws.Range("A3", ws.Range("A" & Rows.Count).End(xlUp))
         If IsNumeric(Left(Cl, 5)) Then
            Uniq = Mid(Cl, 6, 4)
            If Uniq <> "" Then .Item(Uniq) = Empty
         End If
      Next Cl
      For Each Ky In .Keys
         ws.Range("A2:O2").AutoFilter 1, "*" & Ky & "*"


        'use template and copy it
    Sheets("Template").Select
    Sheets("Template").Copy After:=Sheets(Sheets.Count) 'before:=Sheets(3)
'   Sheets("Template (2)").Move before:=Sheets(3)       'uncomment to rearange from bigger to smaller
    Sheets("Template (2)").Name = Ky
  
    
         
'   Sheets.Add(, Sheets(Sheets.Count)).Name = Ky  'uncomment if not using template and just empty sheet


         Intersect(ws.AutoFilter.Range.EntireRow, ws.Range("A:A,B:B,O:O,AD:AD")).Copy Range("A6")
      Next Ky
      ws.AutoFilterMode = False
   End With
End Sub

sorry completely forgot the code

 

[DanteAmor]

Try this

I guess this "Line: 51106-02 AB" is in column A

Sub CopyToNewTempSheet()
    'define varibales
[COLOR=#0000ff]   Dim Cl As Range, ws As Worksheet, Ky As Variant[/COLOR]
[COLOR=#0000ff]   Dim Uniq As String, zone As String, n As Long, zones As Variant[/COLOR]
   
   Application.ScreenUpdating = False
   Set ws = Sheets("Data")
   ws.AutoFilterMode = False
   With CreateObject("scripting.dictionary")
      For Each Cl In ws.Range("A3", ws.Range("A" & Rows.Count).End(xlUp))
[COLOR=#0000ff]         If Left(Cl, 4) = "Line" Then[/COLOR]
[COLOR=#0000ff]             zone = Mid(Cl, 16, 2)[/COLOR]
[COLOR=#0000ff]         End If[/COLOR]
         If IsNumeric(Left(Cl, 5)) Then
            Uniq = Mid(Cl, 6, 4)
            If Uniq <> "" Then .Item(Uniq) = zone 'Empty
         End If
      Next Cl
[COLOR=#0000ff]      n = 0[/COLOR]
[COLOR=#0000ff]      zones = .Items[/COLOR]
      For Each Ky In .Keys
        ws.Range("A2:O2").AutoFilter 1, "*" & Ky & "*"
        'use template and copy it
        'Sheets("Template").Select
        Sheets("Template").Copy After:=Sheets(Sheets.Count) 'before:=Sheets(3)
    '   Sheets("Template (2)").Move before:=Sheets(3)       'uncomment to rearange from bigger to smaller
        Sheets("Template (2)").Name = Ky
         
    '   Sheets.Add(, Sheets(Sheets.Count)).Name = Ky  'uncomment if not using template and just empty sheet


        Intersect(ws.AutoFilter.Range.EntireRow, ws.Range("A:A,B:B,O:O,AD:AD")).Copy Range("A6")
[COLOR=#0000ff]        zone = zones(n)[/COLOR]
[COLOR=#0000ff]        n = n + 1[/COLOR]
[COLOR=#0000ff]        Range("A1").Value = zone[/COLOR]
      Next Ky
      ws.AutoFilterMode = False
   End With
End Sub

 

[excelnoobhere]

Try this

I guess this "Line: 51106-02AB" is in column A

Sub CopyToNewTempSheet()
    'define varibales
[COLOR=#0000ff]   Dim Cl As Range, ws As Worksheet, Ky As Variant[/COLOR]
[COLOR=#0000ff]   Dim Uniq As String, zone As String, n As Long, zones As Variant[/COLOR]
   
   Application.ScreenUpdating = False
   Set ws = Sheets("Data")
   ws.AutoFilterMode = False
   With CreateObject("scripting.dictionary")
      For Each Cl In ws.Range("A3", ws.Range("A" & Rows.Count).End(xlUp))
[COLOR=#0000ff]         If Left(Cl, 4) = "Line" Then[/COLOR]
[COLOR=#0000ff]             zone = Mid(Cl, 16, 2)[/COLOR]
[COLOR=#0000ff]         End If[/COLOR]
         If IsNumeric(Left(Cl, 5)) Then
            Uniq = Mid(Cl, 6, 4)
            If Uniq <> "" Then .Item(Uniq) = zone 'Empty
         End If
      Next Cl
[COLOR=#0000ff]      n = 0[/COLOR]
[COLOR=#0000ff]      zones = .Items[/COLOR]
      For Each Ky In .Keys
        ws.Range("A2:O2").AutoFilter 1, "*" & Ky & "*"
        'use template and copy it
        'Sheets("Template").Select
        Sheets("Template").Copy After:=Sheets(Sheets.Count) 'before:=Sheets(3)
    '   Sheets("Template (2)").Move before:=Sheets(3)       'uncomment to rearange from bigger to smaller
        Sheets("Template (2)").Name = Ky
         
    '   Sheets.Add(, Sheets(Sheets.Count)).Name = Ky  'uncomment if not using template and just empty sheet


        Intersect(ws.AutoFilter.Range.EntireRow, ws.Range("A:A,B:B,O:O,AD:AD")).Copy Range("A6")
[COLOR=#0000ff]        zone = zones(n)[/COLOR]
[COLOR=#0000ff]        n = n + 1[/COLOR]
[COLOR=#0000ff]        Range("A1").Value = zone[/COLOR]
      Next Ky
      ws.AutoFilterMode = False
   End With
End Sub

that worked perfectly thank you, I'm trying to put the date so i can know when it was generated with the title but its not working, anyways around this?
Range("A1").Value = "Zone" + zone + "Generated on:" =NOW()

also is there way a i can change the test to be bold and bigger size?

 

[DanteAmor]

that worked perfectly thank you, I'm trying to put the date so i can know when it was generated with the title but its not working, anyways around this?
Range("A1").Value = "Zone" + zone + "Generated on:" =NOW()

also is there way a i can change the test to be bold and bigger size?

Range("A1").Value = "Zone : " & zone & " - Generated on: " & Now()[COLOR=#0000FF] [/COLOR]

Perform the necessary tests.

 

[excelnoobhere]

Range("A1").Value = "Zone : " & zone & " - Generated on: " & Now()

Perform the necessary tests.

thank you so much that did it!

 

[DanteAmor]

thank you so much that did it!

I'm glad to help you. Thanks for the feedback.