VBA Count question

[deanmoakes]

Hi I have the below VBA code that currently picks up and remembers the sequence of numbers. I am trying to change this so that it only picks up the same number once. The numbers will always be in acending order.

This is a loop and it enters the sequence in a certain cell so that it then initiates the next part of the macro. before moving to the next number in the sequence.

EG.
list of full numbers: 1, 1, 1, 2, 2, 3, 3, 3, 3, 3, 4, 4, 4, 5, 6, 7, 8, 9.
This currently pulls back: 1, 1, 1, 2, 2, 3, 3, 3, 3, 3, 4, 4, 4, 5, 6, 7, 8, 9.
I require it to be: 1, 2, 3, 4, 5, 6, 7, 8, 9.

Any help would be appreciated.




Sub LOOP_()
Dim Companies() As String
Dim count As Integer
Dim i As Integer
Dim finished As Boolean
Dim topoflist As String
count = 0
Sheets("Input of paragon").Activate
Range("A2").Select
topoflist = ActiveCell.Value
'Sheets("Data Input").Select
'Range(topoflist).Select
Do
count = count + 1
ReDim Preserve Companies(count)
Companies(count) = ActiveCell.Value
ActiveCell.Offset(1, 0).Activate
If ActiveCell.Value = "" Then finished = True
Loop Until finished
Range("a1").Select

For i = 1 To UBound(Companies)
Sheets("test").Activate
Range("a1").Value = Companies(i)

Calculate

Call rename_sheet

Next
End Sub


Sub rename_sheet()
Sheets.Add.Name = "Sheet1001"
Sheets("input of paragon").Select
Sheets("Sheet1001").Name = Range("w11").Text
End Sub

 

[machopicho]

If you have excel 2007:

Sub Macro1()
    Columns("A:A").Select
    ActiveSheet.Range("$A$1:$A$22").RemoveDuplicates Columns:=1, Header:=xlNo
End Sub

 

[VBACO]

I would input an IF statement to check if the value is already in the array. If it is then move past writing it again and continue on.

 

[machopicho]

In your cell, are the numbers whole written as:
1, 1, 1, 2, 2, 3, 3, 3, 3, 3, 4, 4, 4, 5, 6, 7, 8, 9.
with the same punctuation and spaces?

 

[Domenic]

Assuming that Column A, starting at A2 in sheet "Input Data", contains the source data, the following macro lists the unique values in sheet "test", starting at A1...

[FONT=Verdana][COLOR=darkblue]Option[/COLOR] [COLOR=darkblue]Explicit[/COLOR][/FONT]
 
[FONT=Verdana][COLOR=darkblue]Sub[/COLOR] test()[/FONT]
 
[FONT=Verdana]  [COLOR=green]'Set a reference (Tools > References) to Microsoft Scritping Runtime[/COLOR][/FONT]
 
[FONT=Verdana]  [COLOR=darkblue]Dim[/COLOR] objDict [COLOR=darkblue]As[/COLOR] Dictionary[/FONT]
[FONT=Verdana]  [COLOR=darkblue]Dim[/COLOR] wksSource [COLOR=darkblue]As[/COLOR] Worksheet[/FONT]
[FONT=Verdana]  [COLOR=darkblue]Dim[/COLOR] wksDest [COLOR=darkblue]As[/COLOR] Worksheet[/FONT]
[FONT=Verdana]  [COLOR=darkblue]Dim[/COLOR] rngRange [COLOR=darkblue]As[/COLOR] Range[/FONT]
[FONT=Verdana]  [COLOR=darkblue]Dim[/COLOR] rngCell [COLOR=darkblue]As[/COLOR] Range[/FONT]
 
[FONT=Verdana]  [COLOR=darkblue]Set[/COLOR] objDict = CreateObject("Scripting.Dictionary")[/FONT]
 
[FONT=Verdana]  [COLOR=darkblue]Set[/COLOR] wksSource = Worksheets("Data Input")[/FONT]
 
[FONT=Verdana]  [COLOR=darkblue]Set[/COLOR] wksDest = Worksheets("test")[/FONT]
 
[FONT=Verdana]  [COLOR=darkblue]With[/COLOR] wksSource[/FONT]
[FONT=Verdana]      [COLOR=darkblue]Set[/COLOR] rngRange = .Range("A2", .Cells(.Rows.Count, "A").End(xlUp))[/FONT]
[FONT=Verdana]  [COLOR=darkblue]End[/COLOR] [COLOR=darkblue]With[/COLOR][/FONT]
 
[FONT=Verdana]  [COLOR=darkblue]For[/COLOR] [COLOR=darkblue]Each[/COLOR] rngCell [COLOR=darkblue]In[/COLOR] rngRange[/FONT]
[FONT=Verdana]      [COLOR=darkblue]With[/COLOR] objDict[/FONT]
[FONT=Verdana]          [COLOR=darkblue]If[/COLOR] .Exists(rngCell.Value) [COLOR=darkblue]Then[/COLOR][/FONT]
[FONT=Verdana]              [COLOR=green]'Do nothing[/COLOR][/FONT]
[FONT=Verdana]          [COLOR=darkblue]Else[/COLOR][/FONT]
[FONT=Verdana]              .Add rngCell.Value, rngCell.Value[/FONT]
[FONT=Verdana]          [COLOR=darkblue]End[/COLOR] [COLOR=darkblue]If[/COLOR][/FONT]
[FONT=Verdana]      [COLOR=darkblue]End[/COLOR] [COLOR=darkblue]With[/COLOR][/FONT]
[FONT=Verdana]  [COLOR=darkblue]Next[/COLOR] rngCell[/FONT]
 
[FONT=Verdana]  wksDest.Range("A1").Resize(objDict.Count, 1).Value = WorksheetFunction.Transpose(objDict.Keys)[/FONT]
 
[FONT=Verdana]  MsgBox "Completed...", vbInformation[/FONT]
 
[FONT=Verdana]End [COLOR=darkblue]Sub[/COLOR][/FONT]

 

[AlphaFrog]

This uses the Filter Uniques method for what it's worth.

Sub LOOP_()
    Dim Companies As Range
    Dim cell As Range
    
    With Sheets("Input of paragon")
        Set cell = .Range("A" & Rows.count).End(xlUp)
        [COLOR="Red"].Range("A1", cell).AdvancedFilter Action:=xlFilterInPlace, Unique:=True[/COLOR]
        Set Companies = .Range("A2", cell).SpecialCells(xlCellTypeVisible)
        .ShowAllData
    End With
    
    For Each cell In Companies
        Sheets("test").Range("A1").Value = cell.Value
        'Calculate
        Sheets.Add.Name = Sheets("input of paragon").Range("w11")
    Next cell
    
End Sub