Microsoft Excel - VBA: Create an array for unique occurences in column F

Asked By Rowland Hamilton on 26-Sep-11 03:07 PM
Folks: VBA: How do I create an array for the unique occurences in column F of my spreadsheet? I want to add a worksheet with tab name labeled after each unique occurence, skip blanks. - Thank you, Rowland Hamilton
Radhika roy replied to Rowland Hamilton on 26-Sep-11 04:12 PM
try this code

Sub unique() 
 
Dim arr As New Collection, a
 
Dim aFirstArray() As Variant
 
Dim i As Long

  aFirstArray
() = Array("Banana", "Apple", "Orange", "Tomato", "Apple", _
 
"Lemon", "Lime", "Lime", "Apple")

 
On Error Resume Next
 
For Each a In aFirstArray
     arr
.Add a, a
 
Next

 
For i = 1 To arr.Count
     Cells
(i, 1) = arr(i)
 
Next

End Sub
follow this link
You may want to look at my attempts that depend on an extra column in Data Submitted in which the ID
 is isolated from the URL
 'Data Submitted'!E2: =ArrayFormula(RegExReplace( 'Data Submitted'!C2:C ; "^(.*?id=)(.*)(&?.*?)$" ; "$2" ))

This extra column was required for the computations in the sheet Results (ahab);
'Results (ahab)'!A6: =ArrayFormula(HYPERLINK( TRANSPOSE(SPLIT( CONCATENATE( IFERROR(REPT( TRANSPOSE("http://www.newphp?id="&'Data Submitted'!E2:E) ;  TRANSPOSE('Data Submitted'!A2:A)=INDEX( QUERY('Data Submitted'!A2:E ; "Select E, max(A) Where E <>'' Group by E Label max(A) '' " ; 0) ;0;2))&CHAR(10))); CHAR(10))) ; TRANSPOSE(SPLIT( CONCATENATE( IFERROR(REPT( TRANSPOSE('Data Submitted'!B2:B8) ;  TRANSPOSE('Data Submitted'!A2:A)=INDEX( QUERY('Data Submitted'!A2:E ; "Select E, max(A) 
Where E <>'' Group by E Label max(A) '' " ; 0) ;0;2))&CHAR(10))); CHAR(10)))))

'Results (ahab)'!B6: =INDEX( QUERY('Data Submitted'!A2:E ; "Select E, max(A) 
Where E <>'' Group by E Label max(A) '' " ; 0) ; 0 ; 1)
This site describes how to get a sorted list by formula without having to sort the 
original list

hope this will help u

Rowland Hamilton replied to Radhika roy on 26-Sep-11 07:09 PM
Radhika: Doesn't look like this could derive the array, more like create the sheets if I already had the array. - Thank you, Rowland
Rowland Hamilton replied to Rowland Hamilton on 26-Sep-11 07:53 PM
MVP Alpha Frog from Mr Excel Formums hooked me up with this but I need help modifying it:

Sub Add_WS_for_Uniques()
   
    Dim Lastrow As Long, rngUniques As Range, cell As Range, ws As Worksheet, HCCosts 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"
          Sheets.Add(After:=Sheets(Sheets.Count)).Name = cell.Value
        End If
      End If
    Next cell
    On Error GoTo 0
   
    Application.ScreenUpdating = True

End Sub

CODE ENDS

Now, 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?

Meantime, I tried this, but array formula didn't work:

CODE BEGINS: 

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

CODE


Thank you, Rowland

Rowland Hamilton replied to Radhika roy on 26-Sep-11 08:47 PM

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".


[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
   
    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

[/CODE]


Help, thanks - Rowland


Note: saw this, mayy help later:

Don't know if I want to use this, but it still doesn't capture the array:
Dim d As Object 
Set d = CreateObject("Scripting.Dictionary") 
'Set d = New Scripting.Dictionary 
 
Dim i As Long 
For i = LBound(myArray) To UBound(myArray) 
    d
(myArray(i)) = 1 
Next
 
Dim v As Variant 
For Each v In d.Keys() 
   
'd.Keys() is a Variant array of the unique values in myArray. 
   
'v will iterate through each of them. 
Next

wally eye replied to Rowland Hamilton on 26-Sep-11 11:57 PM
I find it easiest to sort the data, then iterate through it looking for unique entries:

Public Function UniqueList(ByVal rngCurr As Excel.Range) As Variant

    Dim arrInput          As Variant
    Dim arrOutput()        As Variant

    Dim lngRow          As Long

    arrInput = rngCurr.Value
    Call QuickSort2(arrInput)

    ReDim arrOutput(1 To 1)
    arrOutput(LBound(arrOutput)) = arrInput(LBound(arrInput), 1)
    For lngRow = LBound(arrInput) + 1 To UBound(arrInput)
      If arrInput(lngRow, 1) <> arrInput(lngRow - 1, 1) Then
        ReDim Preserve arrOutput(1 To UBound(arrOutput) + 1)
        arrOutput(UBound(arrOutput)) = arrInput(lngRow, 1)
      End If
    Next lngRow

    UniqueList = Application.Transpose(arrOutput)

End Function


Public Sub QuickSort2(ByRef pvarArray As Variant, Optional ByVal plngLeft As Long, Optional ByVal plngRight As Long)
    Dim lngFirst As Long
    Dim lngLast As Long
    Dim varMid As Variant
    Dim varSwap As Variant
   
    If plngRight = 0 Then
      plngLeft = LBound(pvarArray)
      plngRight = UBound(pvarArray)
    End If
    lngFirst = plngLeft
    lngLast = plngRight
    varMid = pvarArray(Int((plngLeft + plngRight - 1) \ 2), 1)
    Do
      Do While pvarArray(lngFirst, 1) < varMid And lngFirst < plngRight
        lngFirst = lngFirst + 1
      Loop
      Do While varMid < pvarArray(lngLast, 1) And lngLast > plngLeft
        lngLast = lngLast - 1
      Loop
      If lngFirst <= lngLast Then
        varSwap = pvarArray(lngFirst, 1)
        pvarArray(lngFirst, 1) = pvarArray(lngLast, 1)
        pvarArray(lngLast, 1) = varSwap
        lngFirst = lngFirst + 1
        lngLast = lngLast - 1
      End If
    Loop Until lngFirst > lngLast
    If plngLeft < lngLast Then QuickSort2 pvarArray, plngLeft, lngLast
    If lngFirst < plngRight Then QuickSort2 pvarArray, lngFirst, plngRight
End Sub

In vba, you can just feed it a range:

dim arrUnique      as variant

arrunique = uniquelist(worksheets("Sheet1").Range("D2:D1024"))

or something like that.
wally eye replied to wally eye on 27-Sep-11 12:11 AM
So, the final result would look something like:

public sub CreateSheets()

  dim arrUnique()      as variant
  dim lngLastRow      as long
  dim lngCurrRow      as long

  lnglastrow = worksheets("2012HC").columns(6).find(What:="*", After:=[F1], _
    SearchDirection:=xlprevious, SearchOrder:=xlbyrows).row
  arrunique = UniqueList(worksheets("2012HC").cells(2,6).resize(lnglastrow-1,1).value)
 
  for lngcurrrow = lbound(arrunique) to ubound(arrunique)
    if arrunique(lngcurrrow,1) > "" then
      Sheets.Add(After:=Sheets(Sheets.count)).Name = arrunique(lngcurrrow,1)
    endif
  next lngcurrrow

end sub

Rowland Hamilton replied to wally eye on 27-Sep-11 05:20 AM

Wally eye: Thank you so much.


It worked but didn't know how to add the rest of my code or if it did some of the other things I wanted.


Requests:

1)  I can't sort, I have to leave source data as is (do I need to copy it to new sheet and sort, or can I do this without sorting, like the special filter method Wally Eye used?).

2) Could you add some notes to the code to explain the parts?

3) Do they need to be public functions, what's the difference/advantage? so if I sort, that doesn't actually sort the sheet 4) Could I create an array out of the Unique set I defined with th eprevious method? How?

5) I was already able to create these sheets before, but how do I add the copy/paste code to bring in data from my lookup table?


Thank you, Rowland

Rowland Hamilton replied to Rowland Hamilton on 27-Sep-11 05:22 AM
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

Pichart Y. replied to Rowland Hamilton on 27-Sep-11 12:50 PM
Hi Rowland,

I am not sure if I understand your point. Here I design like this.... no Array at all.
  1. assume that the list of name which you want to be sheet name is in sheet("Main") column A
  2. The step will be 
    • Sort the range of the name so that your new sheet will be sorted.
    • run code to check if the name occurs 1st time, then add new sheet and name it as that name
    • If the name is duplicate with some previous name, skip/do nothing
    • Till last row in range
  3. Here is the attachment...Vba_addShNonDupInRng.zip
------------------------------- Code start ---------------------------------------------
Sub AddShWithNmInRng()

' Sort data
    Range("A1:A8").Select
    Application.CutCopyMode = False
    Selection.Sort Key1:=Range("A2"), Order1:=xlAscending, Header:=xlYes, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal
        
'fine unique name then add sheet with name of ref cell
For Each cell In Sheets("main").Range("A2:A8")
        If WorksheetFunction.CountIf(Sheets("main").Range("A2:A" & cell.Row), cell.Value) = 1 Then
                Sheets.Add(After:=Sheets(Sheets.Count)).Name = cell.Value
        End If
Next
MsgBox ("Done!!!")
End Sub
------------------------------------- End of Code ----------------------------------------

Sorry if I misunderstand.

Pichart Y.