Dynamically creating worksheet tabs based on unique values in a column

D

DoctorV

I have a workbook which runs a macro that utilizes Microsoft Query t
pull data from an Access Query into a Sheet named MainForm. This par
works just fine. After this happens, I need another Macro to determin
the unique values in Column D (Field Name in Row 1 for this is Mo
Number) range is cell d2 to however many rows are retrieved, and the
create new worksheet tabs based on the Unique Value and copy and past
all corresponding data and name the new sheet tab whatever the Uniqu
Value is.

Example: Mod Number would have Unique Values of 00 01 02 03 04 05. I
would then create a worksheet tabs named 00 01 02 03 04 05 and the
copy all of the data in the MainForm tab where Mod Number = 00 into th
newly created 00 tab
 
D

DoctorV

Keeps breaking here:rng.Columns(4).AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=.Range("IV1"), Unique:=True

Here is the module

Sub Copy_With_AdvancedFilter()
Dim ws1 As Worksheet
Dim WSNew As Worksheet
Dim rng As Range
Dim cell As Range
Dim Lrow As Long

Set ws1 = Sheets("MainForm")
Set rng = ws1.Range("a1:ab64000")
'Use a Dynamic range name
http://www.contextures.com/xlNames01.html#Dynamic
'This example filter on the first column in the range (change thi
if needed)

With ws1
rng.Columns(4).AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=.Range("IV1"), Unique:=True
'You see that the last two columns of the worksheet are used t
make a Unique list
'and add the CriteriaRange.(you can't use this macro if you us
this columns)
Lrow = .Cells(Rows.Count, "IV").End(xlUp).Row
.Range("IU1").Value = .Range("IV1").Value

For Each cell In .Range("IV2:IV" & Lrow)
.Range("IU2").Value = cell.Value

Set WSNew = Sheets.Add
On Error Resume Next
WSNew.Name = cell.Value
If Err.Number > 0 Then
MsgBox "Change the name of : " & WSNew.Name &
manually"
Err.Clear
End If
On Error GoTo 0

rng.AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=.Range("IU1:IU2"), _
CopyToRange:=WSNew.Range("A1"), _
Unique:=False
Next
.Columns("IU:IV").Clear
End With
End Su
 
R

Ron de Bruin

Hi

I run this on a test workbook without problems.
Send me your workbook and I take a look at it for you

Sub Copy_With_AdvancedFilter()
Dim ws1 As Worksheet
Dim WSNew As Worksheet
Dim rng As Range
Dim cell As Range
Dim Lrow As Long

Set ws1 = Sheets("Sheet1")
Set rng = ws1.Range("a1:ab64000")
'Use a Dynamic range name, http://www.contextures.com/xlNames01.html#Dynamic
'This example filter on the first column in the range (change this if needed)

With ws1
rng.Columns(4).AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=.Range("IV1"), Unique:=True
'You see that the last two columns of the worksheet are used to make a Unique list
'and add the CriteriaRange.(you can't use this macro if you use this columns)
Lrow = .Cells(Rows.Count, "IV").End(xlUp).Row
.Range("IU1").Value = .Range("IV1").Value

For Each cell In .Range("IV2:IV" & Lrow)
.Range("IU2").Value = cell.Value

Set WSNew = Sheets.Add
On Error Resume Next
WSNew.Name = cell.Value
If Err.Number > 0 Then
MsgBox "Change the name of : " & WSNew.Name & " manually"
Err.Clear
End If
On Error GoTo 0

rng.AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=.Range("IU1:IU2"), _
CopyToRange:=WSNew.Range("A1"), _
Unique:=False
Next
.Columns("IU:IV").Clear
End With
End Sub
 
D

DoctorV

Ron,
It is now breaking here
rng.AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=.Range("IU1:IU2"), _
CopyToRange:=WSNew.Range("A1"), _
Unique:=False

It is creating a new tab named 0 which does correspond to one of th
Mod Numbers and all of the Unique mod Numbers are showing up in colum
IV2 through IV16 so there is just something else not quite right ye
 
W

writetoevv

Joined
Apr 18, 2012
Messages
2
Reaction score
0
Hi Ron

Thanks a million ton.

After 2 hours of my search in google, i found this link. this is what exactly i want to do. I tested the same with sample data. It worked as expected.

I need one favor from you.
Can you let me know how can i change the macro to create a new workbook for each set of rows of column A rather than creating new worksheet in existing workbook.
bcoz my workbook contains more than 10,00,000 columns & i am using xcel2003.

Waiting for your reply.


Cheers
Vishy





Ron de Bruin said:
Hi

I run this on a test workbook without problems.
Send me your workbook and I take a look at it for you

Sub Copy_With_AdvancedFilter()
Dim ws1 As Worksheet
Dim WSNew As Worksheet
Dim rng As Range
Dim cell As Range
Dim Lrow As Long

Set ws1 = Sheets("Sheet1")
Set rng = ws1.Range("a1:ab64000")
'Use a Dynamic range name, http://www.contextures.com/xlNames01.html#Dynamic
'This example filter on the first column in the range (change this if needed)

With ws1
rng.Columns(4).AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=.Range("IV1"), Unique:=True
'You see that the last two columns of the worksheet are used to make a Unique list
'and add the CriteriaRange.(you can't use this macro if you use this columns)
Lrow = .Cells(Rows.Count, "IV").End(xlUp).Row
.Range("IU1").Value = .Range("IV1").Value

For Each cell In .Range("IV2:IV" & Lrow)
.Range("IU2").Value = cell.Value

Set WSNew = Sheets.Add
On Error Resume Next
WSNew.Name = cell.Value
If Err.Number > 0 Then
MsgBox "Change the name of : " & WSNew.Name & " manually"
Err.Clear
End If
On Error GoTo 0

rng.AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=.Range("IU1:IU2"), _
CopyToRange:=WSNew.Range("A1"), _
Unique:=False
Next
.Columns("IU:IV").Clear
End With
End Sub


--
Regards Ron de Bruin
http://www.rondebruin.nl


"DoctorV >" <<[email protected]> wrote in message news:D[email protected]...
> Keeps breaking here:rng.Columns(4).AdvancedFilter _
> Action:=xlFilterCopy, _
> CopyToRange:=.Range("IV1"), Unique:=True
>
> Here is the module
>
> Sub Copy_With_AdvancedFilter()
> Dim ws1 As Worksheet
> Dim WSNew As Worksheet
> Dim rng As Range
> Dim cell As Range
> Dim Lrow As Long
>
> Set ws1 = Sheets("MainForm")
> Set rng = ws1.Range("a1:ab64000")
> 'Use a Dynamic range name,
> http://www.contextures.com/xlNames01.html#Dynamic
> 'This example filter on the first column in the range (change this
> if needed)
>
> With ws1
> rng.Columns(4).AdvancedFilter _
> Action:=xlFilterCopy, _
> CopyToRange:=.Range("IV1"), Unique:=True
> 'You see that the last two columns of the worksheet are used to
> make a Unique list
> 'and add the CriteriaRange.(you can't use this macro if you use
> this columns)
> Lrow = .Cells(Rows.Count, "IV").End(xlUp).Row
> Range("IU1").Value = .Range("IV1").Value
>
> For Each cell In .Range("IV2:IV" & Lrow)
> Range("IU2").Value = cell.Value
>
> Set WSNew = Sheets.Add
> On Error Resume Next
> WSNew.Name = cell.Value
> If Err.Number > 0 Then
> MsgBox "Change the name of : " & WSNew.Name & "
> manually"
> Err.Clear
> End If
> On Error GoTo 0
>
> rng.AdvancedFilter Action:=xlFilterCopy, _
> CriteriaRange:=.Range("IU1:IU2"), _
> CopyToRange:=WSNew.Range("A1"), _
> Unique:=False
> Next
> Columns("IU:IV").Clear
> End With
> End Sub
>
>
> ---
> Message posted from http://www.ExcelForum.com/
>
Click to expand...
 

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Similar Threads

Dynamically creating worksheet tabs based on unique values in a column 2
Calculating occupational sick pay entitlement 0
Lookup based on reference 5
Capturing data only when a column "Value" changes 9
How to enter start and end date/time in excel based on some specific value. 7
Merge various cells value in one row into one cell 3
Insert and propagate Rows - based on a format rule 4
Count entries in the column translating to minutes. 5

Top