VBA: Create tab for each unique occurence in column F

[Rowland Hamilton]

<TABLE cellSpacing=0 cellPadding=2 width="100%" border=0><TBODY><TR><TD align=left>Folks: VBA: How do I create an array for the unique occurences in column F of my spreadsheet? I want to add worksheets with tab name labeled after each unique occurence, skip blanks. - Thank you, Rowland Hamilton</TD></TR></TBODY></TABLE>

 

[AlphaFrog]

<font face=Courier New><SPAN style="color:#00007F">Sub</SPAN> Add_WS_for_Uniques()<br>    <br>    <SPAN style="color:#00007F">Dim</SPAN> Lastrow <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Long</SPAN>, rngUniques <SPAN style="color:#00007F">As</SPAN> Range, cell <SPAN style="color:#00007F">As</SPAN> Range, ws <SPAN style="color:#00007F">As</SPAN> Worksheet<br>    <br>    <SPAN style="color:#00007F">Set</SPAN> ws = ActiveSheet<br>    Application.ScreenUpdating = <SPAN style="color:#00007F">False</SPAN><br>    <br>    Lastrow = ws.Range("F" & Rows.Count).End(xlUp).Row<br>    ws.Range("F1:F" & Lastrow).AdvancedFilter Action:=xlFilterInPlace, Unique:=<SPAN style="color:#00007F">True</SPAN><br>    <SPAN style="color:#00007F">Set</SPAN> rngUniques = ws.Range("F2:F" & Lastrow).SpecialCells(xlCellTypeVisible)<br>    ws.ShowAllData<br>    <br>    <SPAN style="color:#00007F">On</SPAN> <SPAN style="color:#00007F">Error</SPAN> <SPAN style="color:#00007F">Resume</SPAN> <SPAN style="color:#00007F">Next</SPAN><br>    <SPAN style="color:#00007F">For</SPAN> <SPAN style="color:#00007F">Each</SPAN> cell <SPAN style="color:#00007F">In</SPAN> rngUniques<br>        <SPAN style="color:#00007F">If</SPAN> cell.Value <> "" <SPAN style="color:#00007F">Then</SPAN><br>            <SPAN style="color:#00007F">If</SPAN> Len(Sheets(cell.Value).Name) = 0 <SPAN style="color:#00007F">Then</SPAN><br>                Sheets.Add(After:=Sheets(Sheets.Count)).Name = cell.Value<br>            <SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">If</SPAN><br>        <SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">If</SPAN><br>    <SPAN style="color:#00007F">Next</SPAN> cell<br>    <SPAN style="color:#00007F">On</SPAN> <SPAN style="color:#00007F">Error</SPAN> <SPAN style="color:#00007F">GoTo</SPAN> 0<br>    <br>    ws.Activate<br>    Application.ScreenUpdating = <SPAN style="color:#00007F">True</SPAN><br>    <br><SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">Sub</SPAN></FONT>

 

[Rowland Hamilton]

Awesome as usual, AlphaFrog. - Gonna try it after lunch - Rowland

 

[Rowland Hamilton]

Works, thanks. How can I sort the array sheets alphabetically?

 

[Rowland Hamilton]

How can I capture the new array with the sheet names = cell.Value & " Natives", sort these sheets alphabetically, and use the new array to perform further actions on the sheets?
Thank you, Rowland

 

[Rowland Hamilton]

Once I figure out how to capture these arrays, I'll modify the code to do this:

'Sheets.Add(After:=Sheets(Sheets.Count)).Name = cell.Value & " Natives"

Then, I'll add this to the code (won't repeat defining of terms once I combine code):

Sub continue()
Dim rngUniques As Range, cell As Range, rngSrc As Range, rngDst As Range, ccDst As Range
Dim Lastrow As Long, Firstrow As Long
Dim ws As Worksheet, HCCosts As Worksheet, StaticData As Worksheet
    
    Set HCCosts = Worksheets("2012HC")
    Set StaticData = Worksheets("Static Data")
    
    
    Application.ScreenUpdating = False
    
    Lastrow = HCCosts.Range("F" & Rows.Count).End(xlUp).Row
    HCCosts.Range("F1:F" & Lastrow).AdvancedFilter Action:=xlFilterInPlace, Unique:=True
    Set rngUniques = HCCosts.Range("F2:F" & Lastrow).SpecialCells(xlCellTypeVisible)
    HCCosts.ShowAllData
    
               For Each ws In Workheets(Array(rngUniques))
                
                'copy
                Range("a1").Formula = "Pillar-Ledger"
                Range("b1").Formula = "CE-Description"
                Range("c1").Formula = "CE"
                Range("d1").Formula = "CE Description"
                Range("e1").Formula = "Source Sheet"
                Range("f1").Formula = "Source Column"
                Range("g1").Formula = "multiplier"
                Range("h1").Formula = "LU Col"
                Range("i1").Formula = "Total P&L"
                
            'copy
                
              Lastrow = StaticData.Cells(Rows.Count, "C").End(xlUp).Row
              Set rngSrc = StaticData.Range("C2:H" & Lastrow)
 
            'paste
                Set rngDst = ws.Range("B" & Rows.Count).End(xlUp).Offset(1, 0)
 
                rngSrc.SpecialCells(xlCellTypeVisible).Copy
 
                rngDst.PasteSpecial Paste:=xlPasteValues
                rngDst.PasteSpecial Paste:=xlPasteFormats
                Application.CutCopyMode = False
                
              Firstrow = ws.Cells(Rows.Count, "A").End(xlUp).Row
              Lastrow = ws.Cells(Rows.Count, "B").End(xlUp).Row
              Set ccDst = ws.Range("A" & Firstrow & ":A" & Lastrow)
              ccDst.Formula = ws.Name
        Next ws
End Sub

This gets stuck on array because evidently I can't just make it equal to the rngUniques like that. - Thanks for any help, Rowland

 

[Rowland Hamilton]

My latest attempt: I'm stuck at performing the copy paste actions inbetween the 'UNTESTEDUNTESTED lines (I tried them but those sheet names aren't found so "on error goto 0".

Sub continue()
Dim rngUniques As Range, cell As Range, rngSrc As Range, rngDst As Range, ccDst As Range
Dim Lastrow As Long, Firstrow As Long
Dim ws As Worksheet, HCCosts As Worksheet, StaticData As Worksheet
    
    Set HCCosts = Worksheets("2012HC")
    Set StaticData = Worksheets("Static Data")
    
    Application.ScreenUpdating = False
    
    Lastrow = HCCosts.Range("F" & Rows.Count).End(xlUp).Row
    HCCosts.Range("F1:F" & Lastrow).AdvancedFilter Action:=xlFilterInPlace, Unique:=True
    Set rngUniques = HCCosts.Range("F2:F" & Lastrow).SpecialCells(xlCellTypeVisible)
    HCCosts.ShowAllData
    
    On Error Resume Next
    For Each cell In rngUniques
        If cell.Value <> "" Then
            If Len(Sheets(cell.Value).Name) = 0 Then
                Sheets.Add(After:=Sheets(Sheets.Count)).Name = cell.Value & " Natives"
                    Range("a1").Formula = "Pillar-Ledger"
                    Range("b1").Formula = "CE-Description"
                    Range("c1").Formula = "CE"
                    Range("d1").Formula = "CE Description"
                    Range("e1").Formula = "Source Sheet"
                    Range("f1").Formula = "Source Column"
                    Range("g1").Formula = "multiplier"
                    Range("h1").Formula = "LU Col"
                    Range("i1").Formula = "Total P&L"
                    Range("a2").Value = cell.Value
  'UNTESTEDUNTESTEDUNTESTEDUNTESTEDUNTESTEDUNTESTEDUNTESTEDUNTESTEDUNTESTEDUNTESTEDUNTESTED
       'copy
                
              Lastrow = StaticData.Cells(Rows.Count, "C").End(xlUp).Row
              Set rngSrc = StaticData.Range("C1:H" & Lastrow)
 
            'paste
                Set rngDst = Sheets(cell.Value & "Natives").Name.Range("B" & Rows.Count).End(xlUp).Offset(1, 0)
 
                rngSrc.SpecialCells(xlCellTypeVisible).Copy
 
                rngDst.PasteSpecial Paste:=xlPasteValues
                rngDst.PasteSpecial Paste:=xlPasteFormats
                Application.CutCopyMode = False
                
  'UNTESTEDUNTESTEDUNTESTEDUNTESTEDUNTESTEDUNTESTEDUNTESTEDUNTESTEDUNTESTEDUNTESTEDUNTESTED
             
            End If
        End If
    Next cell
    On Error GoTo 0
    
    Application.ScreenUpdating = True
End Sub

Help, thanks - Rowland

 

[Rowland Hamilton]

Latest solution:

Sub Add_WS_for_Uniques()
Dim rngUniques As Range, cell As Range, rngSrc As Range, rngDst As Range, ccSrc As Range, ccDst As Range
Dim fmlaSrc As Range, fmlaDst As Range
Dim Lastrow As Long, Firstrow As Long
Dim ws As Worksheet, HCCosts As Worksheet, StaticData As Worksheet
    Set HCCosts = Worksheets("2012HC")
    Set StaticData = Worksheets("Static Data")
    
    Application.ScreenUpdating = False
    
    Lastrow = HCCosts.Range("F" & Rows.Count).End(xlUp).Row
    HCCosts.Range("F1:F" & Lastrow).AdvancedFilter Action:=xlFilterInPlace, Unique:=True
    Set rngUniques = HCCosts.Range("F2:F" & Lastrow).SpecialCells(xlCellTypeVisible)
    HCCosts.ShowAllData
    
    On Error Resume Next
    For Each cell In rngUniques
        If cell.Value <> "" Then
            If Len(Sheets(cell.Value).Name) = 0 Then
                Sheets.Add(After:=Sheets(Sheets.Count)).Name = cell.Value & " Natives"
                    Range("a1").Formula = "Pillar-Ledger"
                    Range("h1").Formula = "LU Col"
                    Range("i1").Formula = "Total P&L"
                    Range("a2").Value = cell.Value
            End If
        End If
    Next cell
    On Error GoTo 0
    
       For Each ws In ActiveWorkbook.Sheets '(Array("",""))
            If ws.Name Like "*Natives" Then
            
        'copy Static Data
              Lastrow = StaticData.Cells(Rows.Count, "C").End(xlUp).Row
              Set rngSrc = StaticData.Range("C1:H" & Lastrow)
 
        'paste Static Data
                Set rngDst = ws.Range("B" & Rows.Count).End(xlUp).Offset(0, 0)
 
                rngSrc.SpecialCells(xlCellTypeVisible).Copy
 
                rngDst.PasteSpecial Paste:=xlPasteValues
                rngDst.PasteSpecial Paste:=xlPasteFormats
                Application.CutCopyMode = False
                
         'copy LU Value
                Lastrow = ws.Range("B" & Rows.Count).End(xlUp).Row
                Set ccSrc = ws.Range("A2")
                
         'paste LU Value
                Set ccDst = ws.Range("A2:A" & Lastrow)
                
                ccSrc.SpecialCells(xlCellTypeVisible).Copy
                
                ccDst.PasteSpecial Paste:=xlPasteValues
                ccDst.PasteSpecial Paste:=xlPasteFormats
                Application.CutCopyMode = False
                
         'Input LU Col and Total P&L Formulas
                ws.Range("h2").Formula = "=IF(ISERROR(MATCH(F2,INDIRECT(""'""&E2&""'!E1:Z1""),0)),0," & _
                "(MATCH(F2,INDIRECT(""'""&E2&""'!E1:Z1""),0)))"
                
                ws.Range("i2").Formula = "=IF(ISNA(SUMIF('2012HC'!F:F,$A2,INDEX('2012HC'!$A:$Z," & _
                ",MATCH($F2,'2012HC'!$A$1:$Z$1,0)))),0,SUMIF('2012HC'!F:F,$A2," & _
                "INDEX('2012HC'!$A:$Z,,MATCH($F2,'2012HC'!$A$1:$Z$1,0))))"
                
          'copy Formulas
                Set fmlaSrc = ws.Range("h2:i2")
                
          'paste Formulas
                Set fmlaDst = ws.Range("h2:i" & Lastrow)
                
                fmlaSrc.SpecialCells(xlCellTypeVisible).Copy
                
                fmlaDst.PasteSpecial Paste:=xlAll
                Application.CutCopyMode = False
                
          'Autofit columns
                With ws.Columns("A:K")
                    .AutoFit
                    .ColumnWidth = .ColumnWidth + 2
                End With
               
                'ws.Outline.ShowLevels RowLevels:=1, ColumnLevels:=2
            End If
         Next ws
    Application.ScreenUpdating = True
End Sub

Couldn't figure out how to handle it all in the first loop so I just added a cheasier loop at the bottom.

Thank you - Rowland

 

[Rowland Hamilton]

Alpha Frog, et al:

Folks, I'm trying to buld on Alpha Frog's code and use the rngUniques as an array that I referr to for my For Next loop to populate (copy/paste) my newly created worksheets.

Here is what I have so far:Dummydata-2012 HC Costs Budget v2.zip

It works but I want it to be better.

If we kept most of what I have here, the changes I would want are:

Don't want to referr to all sheets like "*Natives" because user could create a sheet with same naming convention that I don't want to operate on, and I already created the sheets, generated the sheet names to begin with, so

Replace:

For Each ws In ActiveWorkbook.Sheets
            If ws.Name Like "*Natives" Then

with some functioning version of this:

For Each ws In ActiveWorkbook.Sheets(Array(Lbound(arryUniques & " Natives"),Ubound(arryuniques & " Natives"))

Perhaps instead of making this a range in the beginning:

Set rngUniques = HCCosts.Range("E2:E" & Lastrow).SpecialCells(xlCellTypeVisible)

Could it be set as an array right off the bat, then referred to in later code?

Even if there is better way, I still want to learn how to capture the unique occurences and turn them into an actual array I can referr to throughout the code.

Thank you, Rowland

 

[Rowland Hamilton]

Note: example has moved column F to column E. Got rid of some stuff.
-Rowland