array in vba

G

G2K

Active Member
Joined
May 29, 2009
Messages
355
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
 

Excel Facts

When did Power Query debut in Excel?
Although it was an add-in in Excel 2010 & Excel 2013, Power Query became a part of Excel in 2016, in Data, Get & Transform Data.
Sort by date Sort by votes
Try:

Code: 
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
 
Upvote 0
Thanks Andrew,

It's working perfectly fine now. Worderful code

thanks again...
 
Upvote 0
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
 
Upvote 0
Try:

Code: 
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
 
Upvote 0
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
 
Upvote 0
This deletes all the other sheets and recreates the necessary ones:

Code: 
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
 
Upvote 0
You must log in or register to reply here.

Similar threads

J
  • Solved
Filter a listbox containing 12 columns using a single searchbox
Replies
8
Views
806
Anthony47
A
K
  • Question Question
VBA to filter Worksheet on manager column & copy all data to new workbook
Replies
8
Views
1K
kizzie37
K
I
  • Question Question
Unable to run VBA code
Replies
6
Views
141
RoryA
RoryA
S
  • Question Question
Change macro range from column A to B
2
Replies
10
Views
136
sachin483
S
F
  • Question Question
VBA: Autofilter containing specific cell value from another Worksheet
Replies
1
Views
557
Fanalis
F

Forum statistics

Threads
1,224,607
Messages
6,179,871
Members
452,949
Latest member
Dupuhini

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top