array in vba

[G2K]

Hi all,

i want to check unique records from specefic column and based on that criteria i want to paste all data from main sheet to other sheet.

pls check the code below and help me to fix this problem.

Private Sub test()
Dim i As Integer
Dim ClientName() As String
ClientName = StoreUniqueRecordsInArray
For i = 1 To rcount

Sheets("sheet1").Select

Selection.AutoFilter

Selection.AutoFilter Field:=2, Criteria1:=ClientName(i) /error script out of range

Cells.Copy

Sheets.Add

ActiveSheet.Paste

ActiveSheet.Name = ClientName(i)

Sheets("sheet1").Select
Next i
End Sub



Function StoreUniqueRecordsInArray() As String()
Dim strNames() As String
Dim Uniques As New Collection
Dim ReqRange As Range
Set ReqRange = Range("B2:B10000")
rcount = 0
On Error Resume Next
For Each cell In ReqRange
Uniques.Add cell.Value, CStr(cell.Value)
Next cell
For Each Item In Uniques
rcount = rcount + 1
strNames(rcount) = Item

Next Item
StoreUniqueRecordsInArray = strNames
End Function

 

[Andrew Poulsom]

Try:

Sub Test()
    Dim Sh As Worksheet
    Dim Rng As Range
    Dim Cell As Range
    Dim TheList As New Collection
    Dim i As Integer
    Set Sh = Worksheets("Sheet1")
    With Sh
        Set Rng = .Range("B2:B" & .Range("B" & .Rows.Count).End(xlUp).Row)
    End With
'   Create unique list
    On Error Resume Next
    For Each Cell In Rng
        TheList.Add Cell.Value, CStr(Cell.Value)
    Next Cell
    On Error GoTo 0
    Set Rng = Sh.Range("A1").CurrentRegion
    For i = 1 To TheList.Count
        Rng.AutoFilter
        Rng.AutoFilter Field:=2, Criteria1:=TheList(i)
        Worksheets.Add
        Rng.SpecialCells(xlCellTypeVisible).Copy ActiveSheet.Range("A1")
        ActiveSheet.Name = TheList(i)
    Next i
    With Sh
        .AutoFilterMode = False
        .Select
    End With
End Sub

 

[G2K]

Thanks Andrew,

It's working perfectly fine now. Worderful code

thanks again...

 

[G2K]

can we add one more row to delete the spreadsheet if criteria name match the worksheetname, i mean every time code runs,it delete worksheet wchich names are similar to criteria name and adds new sheet if found nay new criteria.

Thanks in advance

 

[Andrew Poulsom]

Try:

Sub Test()
    Dim Sh As Worksheet
    Dim Rng As Range
    Dim Cell As Range
    Dim TheList As New Collection
    Dim i As Integer
    Dim ShTarget As Worksheet
    Set Sh = Worksheets("Sheet1")
    With Sh
        Set Rng = .Range("B2:B" & .Range("B" & .Rows.Count).End(xlUp).Row)
    End With
'   Create unique list
    On Error Resume Next
    For Each Cell In Rng
        TheList.Add Cell.Value, CStr(Cell.Value)
    Next Cell
    On Error GoTo 0
    Set Rng = Sh.Range("A1").CurrentRegion
    For i = 1 To TheList.Count
        Rng.AutoFilter
        Rng.AutoFilter Field:=2, Criteria1:=TheList(i)
        On Error Resume Next
        Set ShTarget = Worksheets(TheList(i))
        If Err = 0 Then
            ShTarget.Cells.Clear
        Else
            Err.Clear
            Set ShTarget = Worksheets.Add
            ShTarget.Name = TheList(i)
        End If
        On Error GoTo 0
        Rng.SpecialCells(xlCellTypeVisible).Copy ShTarget.Range("A1")
    Next i
    With Sh
        .AutoFilterMode = False
        .Select
    End With
End Sub

 

[G2K]

thanks Andrew...it's working prefectly.

but, if we remove any critaria from given range list, the worksheet containing data and name of this criatria should also be deleted. but in given procedere when we add new cretaria, new worksheet added accordingly but it can not delete the worksheet which is not in critaria list.

Regards

 

[Andrew Poulsom]

This deletes all the other sheets and recreates the necessary ones:

Sub Test()
    Dim Sh As Worksheet
    Dim Rng As Range
    Dim ws As Worksheet
    Dim Cell As Range
    Dim TheList As New Collection
    Dim i As Integer
    Dim ShTarget As Worksheet
    Set Sh = Worksheets("Sheet1")
    With Sh
        Set Rng = .Range("B2:B" & .Range("B" & .Rows.Count).End(xlUp).Row)
    End With
    Application.DisplayAlerts = False
    For Each ws In Worksheets
        If ws.Name <> Sh.Name Then ws.Delete
    Next ws
    Application.DisplayAlerts = True
    On Error Resume Next
    For Each Cell In Rng
        TheList.Add Cell.Value, CStr(Cell.Value)
    Next Cell
    On Error GoTo 0
    Set Rng = Sh.Range("A1").CurrentRegion
    For i = 1 To TheList.Count
        Rng.AutoFilter
        Rng.AutoFilter Field:=2, Criteria1:=TheList(i)
        Set ShTarget = Worksheets.Add
        ShTarget.Name = TheList(i)
        Rng.SpecialCells(xlCellTypeVisible).Copy ShTarget.Range("A1")
    Next i
    With Sh
        .AutoFilterMode = False
        .Select
    End With
End Sub