Help please in debugging this macro

[sungen99]

Below is a macro that will take a list of data from sheet1 and firs
create a new spreadsheet for each item located in col C. it will the
take the data on sheet1 and place all the lines of data associated wit
the new spreadsheet. it’s a very nice program but I need to alter it
bit and really cant seem to grasp the logic so I cant do it.

What I need to do is the follow.

Currently the program will place the temp data in col L and J. I nee
it to be placed at AA and AB

Currently the program will look in col C for unique sorts. I need i
to look in col I.

I have attached below the working program the altered code I have done
I can get it to create the new unique spreadsheets but for some reaso
I fail on copying the data. Keep in mind that I am trying to copy A-
on my sheets where the old one was copying A-G.

Thank your for any help.

Sub ExtractReps()
Dim ws1 As Worksheet
Dim wsNew As Worksheet
Dim rng As Range
Dim r As Integer
Dim c As Range
Set ws1 = Sheets("Sheet1")
Set rng = Range("Database")

'extract a list of Sales Reps
ws1.Columns("C:C").Copy _
Destination:=Range("L1")
ws1.Columns("L:L").AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=Range("J1"), Unique:=True
r = Cells(Rows.Count, "J").End(xlUp).Row

'set up Criteria Area
Range("L1").Value = Range("C1").Value

For Each c In Range("J2:J" & r)
'add the rep name to the criteria area
ws1.Range("L2").Value = c.Value
'add new sheet (if required)
'and run advanced filter
If WksExists(c.Value) Then
Sheets(c.Value).Cells.Clear
rng.AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=Sheets("Sheet1").Range("L1:L2"), _
CopyToRange:=Sheets(c.Value).Range("A1"), _
Unique:=False
Else
Set wsNew = Sheets.Add
wsNew.Move After:=Worksheets(Worksheets.Count)
wsNew.Name = c.Value
rng.AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=Sheets("Sheet1").Range("L1:L2"), _
CopyToRange:=wsNew.Range("A1"), _
Unique:=False
End If
Next
ws1.Select
ws1.Columns("J:L").Delete
End Sub
Function WksExists(wksName As String) As Boolean
On Error Resume Next
WksExists = CBool(Len(Worksheets(wksName).Name) > 0)
End Function




My changes…

Sub ExtractReps()
Dim ws1 As Worksheet
Dim wsNew As Worksheet
Dim rng As Range
Dim r As Integer
Dim c As Range
Set ws1 = Sheets("Sheet1")
Set rng = Range("Database")

'extract a list of Sales Reps
ws1.Columns("I:I").Copy _
Destination:=Range("L1")
ws1.Columns("L:L").AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=Range("J1"), Unique:=True
r = Cells(Rows.Count, "J").End(xlUp).Row

'set up Criteria Area
Range("L1").Value = Range("I1").Value

For Each c In Range("J2:J" & r)
'add the rep name to the criteria area
ws1.Range("L2").Value = c.Value
'add new sheet (if required)
'and run advanced filter
If WksExists(c.Value) Then
Sheets(c.Value).Cells.Clear
rng.AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=Sheets("Sheet1").Range("L1:L2"), _
CopyToRange:=Sheets(c.Value).Range("A1"), _
Unique:=False
Else
Set wsNew = Sheets.Add
wsNew.Move After:=Worksheets(Worksheets.Count)
wsNew.Name = c.Value
rng.AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=Sheets("Sheet1").Range("L1:L2"), _
CopyToRange:=wsNew.Range("A1"), _
Unique:=False
End If
Next
ws1.Select
ws1.Columns("J:L").Delete
End Sub
Function WksExists(wksName As String) As Boolean
On Error Resume Next
WksExists = CBool(Len(Worksheets(wksName).Name) > 0)
End Functio

 

[sungen99]

desperate bump

 

[sungen99]

One last desperate request bump...............

 

[Ardus Petus]

Could you upload a (partial) copy of your workbook onto http://cjoint.com/ ,
then post back the link.
That would help reproducing the problem.

Hope I can help

 

[sungen99]

i seem to be having issues with using that site. would it be possible
to send it directly to you? you can just send me a private message if
you wish?

 

[sungen99]

i seem to be having issues with using that site. would it be possible
to send it directly to you? you can just send me a private message if
you wish?

 

[Ardus Petus]

Send it at (e-mail address removed)

Cheers,

 

[Ardus Petus]

Here is your corrected workbook: http://cjoint.com/?gxrNtPSG4r

You must pay attention do defined name "Database": it should reference your
whole data array

HTH