Hello All,
I am using Windows XP/Office 2003 and have the following problem

I have downloaded a file from Debra Dalgleish's Web Site www.contexture.com(File
Name:AdvFilterCity.Zip) and tried to change it to suit my needs.

But I have few problems with it...as shown in the JPG files viz. Before
and After.
(I have made JPG files)

The File name "Before" shows the actual entry and the File name
"After" shows when the macro FilterCities is run.

As can be seen in the file "After" in Columns F & G ...same data is
repeated from columns C & D. This is what is going wrong.

When the macro FilterCities is run I need to have the entire row
(Columns A to H) copied one below other as shown in File "Before"

Following is the macro

Option Explicit

Sub FilterCities()

Dim myCell As Range
Dim wks As Worksheet
Dim DataBaseWks As Worksheet
Dim ListRange As Range
Dim dummyRng As Range
Dim myDatabase As Range
Dim TempWks As Worksheet
Dim rsp As Integer
Dim i As Long

'include bottom most header row
Const TopLeftCellOfDataBase As String = "A4"

'what column has your key values
Const KeyColumn As String = "A"

'where's your data
Set DataBaseWks = Worksheets("Main")
i = DataBaseWks.Range(TopLeftCellOfDataBase).Row - 1

rsp = MsgBox("Include headings?", vbYesNo, "Headings")

Set TempWks = Worksheets.Add

With DataBaseWks
Set dummyRng = .UsedRange
Set myDatabase = .Range(TopLeftCellOfDataBase, _
.Cells.SpecialCells(xlCellTypeLastCell))
End With

'rebuild the List
With DataBaseWks
Intersect(myDatabase, .Columns(KeyColumn)).AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=TempWks.Range("A1"), _
Unique:=True

'Add the heading to the criteria area
TempWks.Range("D1").Value = _
.Cells(.Range(TopLeftCellOfDataBase).Row, KeyColumn).Value
End With

With TempWks
Set ListRange = .Range("a2", .Cells(.Rows.Count,
"A").End(xlUp))
End With

With ListRange
.Sort Key1:=.Cells(1), Order1:=xlAscending, _
Header:=xlNo, OrderCustom:=1, _
MatchCase:=False, Orientation:=xlTopToBottom
End With

'check for individual City worksheets
For Each myCell In ListRange.Cells
If WksExists(myCell.Value) = False Then
Set wks = Sheets.Add
On Error Resume Next
wks.Name = myCell.Value
If Err.Number < 0 Then
MsgBox "Please rename: " & wks.Name
Err.Clear
End If
On Error GoTo 0
wks.Move after:=Sheets(Sheets.Count)
Else
Set wks = Worksheets(myCell.Value)
wks.Cells.Clear
End If

If rsp = 6 Then
DataBaseWks.Rows("1:" & i).Copy Destination:=wks.Range("A1")
End If

'change the criteria in the Criteria range
TempWks.Range("D2").Value = "=" & Chr(34) & "=" & myCell.Value
& Chr(34)

'transfer data to individual City worksheets
If rsp = 6 Then
myDatabase.AdvancedFilter _
Action:=xlFilterCopy, _
CriteriaRange:=TempWks.Range("D1:D2"), _
CopyToRange:=wks.Range("A1").Offset(i, 0), _
Unique:=False
Else
myDatabase.AdvancedFilter _
Action:=xlFilterCopy, _
CriteriaRange:=TempWks.Range("D1:D2"), _
CopyToRange:=wks.Range("A1"), _
Unique:=False
End If
Next myCell

Application.DisplayAlerts = False
TempWks.Delete
Application.DisplayAlerts = True

MsgBox "Data has been sent"
Call SetColumnWidth
Sheets("MAIN").Select
End Sub
Function WksExists(wksName As String) As Boolean
On Error Resume Next
WksExists = CBool(Len(Worksheets(wksName).Name) 0)
End Function

I can mail the JPG files to someone who wish to help me out
Can anybody help me out please?

TIA

Rashid Khan

If you post a bit of your sample data, and examples of what's being
duplicated, someone may be able to help.


wrote:
Hello All,
I am using Windows XP/Office 2003 and have the following problem

I have downloaded a file from Debra Dalgleish's Web Site www.contexture.com(File
Name:AdvFilterCity.Zip) and tried to change it to suit my needs.

But I have few problems with it...as shown in the JPG files viz. Before
and After.
(I have made JPG files)

The File name "Before" shows the actual entry and the File name
"After" shows when the macro FilterCities is run.

As can be seen in the file "After" in Columns F & G ...same data is
repeated from columns C & D. This is what is going wrong.

When the macro FilterCities is run I need to have the entire row
(Columns A to H) copied one below other as shown in File "Before"

Following is the macro

Option Explicit

Sub FilterCities()

Dim myCell As Range
Dim wks As Worksheet
Dim DataBaseWks As Worksheet
Dim ListRange As Range
Dim dummyRng As Range
Dim myDatabase As Range
Dim TempWks As Worksheet
Dim rsp As Integer
Dim i As Long

'include bottom most header row
Const TopLeftCellOfDataBase As String = "A4"

'what column has your key values
Const KeyColumn As String = "A"

'where's your data
Set DataBaseWks = Worksheets("Main")
i = DataBaseWks.Range(TopLeftCellOfDataBase).Row - 1

rsp = MsgBox("Include headings?", vbYesNo, "Headings")

Set TempWks = Worksheets.Add

With DataBaseWks
Set dummyRng = .UsedRange
Set myDatabase = .Range(TopLeftCellOfDataBase, _
.Cells.SpecialCells(xlCellTypeLastCell))
End With

'rebuild the List
With DataBaseWks
Intersect(myDatabase, .Columns(KeyColumn)).AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=TempWks.Range("A1"), _
Unique:=True

'Add the heading to the criteria area
TempWks.Range("D1").Value = _
.Cells(.Range(TopLeftCellOfDataBase).Row, KeyColumn).Value
End With

With TempWks
Set ListRange = .Range("a2", .Cells(.Rows.Count,
"A").End(xlUp))
End With

With ListRange
.Sort Key1:=.Cells(1), Order1:=xlAscending, _
Header:=xlNo, OrderCustom:=1, _
MatchCase:=False, Orientation:=xlTopToBottom
End With

'check for individual City worksheets
For Each myCell In ListRange.Cells
If WksExists(myCell.Value) = False Then
Set wks = Sheets.Add
On Error Resume Next
wks.Name = myCell.Value
If Err.Number < 0 Then
MsgBox "Please rename: " & wks.Name
Err.Clear
End If
On Error GoTo 0
wks.Move after:=Sheets(Sheets.Count)
Else
Set wks = Worksheets(myCell.Value)
wks.Cells.Clear
End If

If rsp = 6 Then
DataBaseWks.Rows("1:" & i).Copy Destination:=wks.Range("A1")
End If

'change the criteria in the Criteria range
TempWks.Range("D2").Value = "=" & Chr(34) & "=" & myCell.Value
& Chr(34)

'transfer data to individual City worksheets
If rsp = 6 Then
myDatabase.AdvancedFilter _
Action:=xlFilterCopy, _
CriteriaRange:=TempWks.Range("D1:D2"), _
CopyToRange:=wks.Range("A1").Offset(i, 0), _
Unique:=False
Else
myDatabase.AdvancedFilter _
Action:=xlFilterCopy, _
CriteriaRange:=TempWks.Range("D1:D2"), _
CopyToRange:=wks.Range("A1"), _
Unique:=False
End If
Next myCell

Application.DisplayAlerts = False
TempWks.Delete
Application.DisplayAlerts = True

MsgBox "Data has been sent"
Call SetColumnWidth
Sheets("MAIN").Select
End Sub
Function WksExists(wksName As String) As Boolean
On Error Resume Next
WksExists = CBool(Len(Worksheets(wksName).Name) 0)
End Function

I can mail the JPG files to someone who wish to help me out
Can anybody help me out please?

TIA

Rashid Khan



--
Debra Dalgleish
Contextures
http://www.contextures.com/tiptech.html

On Feb 15, 6:00 am, Debra Dalgleish wrote:
If you post a bit of your sample data, and examples of what's being
duplicated, someone may be able to help.





wrote:
Hello All,
I am using Windows XP/Office 2003 and have the following problem

I have downloaded a file from Debra Dalgleish's Web Sitewww.contexture.com(File
Name:AdvFilterCity.Zip) and tried to change it to suit my needs.

But I have few problems with it...as shown in the JPG files viz. Before
and After.
(I have made JPG files)

The File name "Before" shows the actual entry and the File name
"After" shows when the macro FilterCities is run.

As can be seen in the file "After" in Columns F & G ...same data is
repeated from columns C & D. This is what is going wrong.

When the macro FilterCities is run I need to have the entire row
(Columns A to H) copied one below other as shown in File "Before"

Following is the macro

Option Explicit

Sub FilterCities()

Dim myCell As Range
Dim wks As Worksheet
Dim DataBaseWks As Worksheet
Dim ListRange As Range
Dim dummyRng As Range
Dim myDatabase As Range
Dim TempWks As Worksheet
Dim rsp As Integer
Dim i As Long

'include bottom most header row
Const TopLeftCellOfDataBase As String = "A4"

'what column has your key values
Const KeyColumn As String = "A"

'where's your data
Set DataBaseWks = Worksheets("Main")
i = DataBaseWks.Range(TopLeftCellOfDataBase).Row - 1

rsp = MsgBox("Include headings?", vbYesNo, "Headings")

Set TempWks = Worksheets.Add

With DataBaseWks
Set dummyRng = .UsedRange
Set myDatabase = .Range(TopLeftCellOfDataBase, _
.Cells.SpecialCells(xlCellTypeLastCell))
End With

'rebuild the List
With DataBaseWks
Intersect(myDatabase, .Columns(KeyColumn)).AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=TempWks.Range("A1"), _
Unique:=True

'Add the heading to the criteria area
TempWks.Range("D1").Value = _
.Cells(.Range(TopLeftCellOfDataBase).Row, KeyColumn).Value
End With

With TempWks
Set ListRange = .Range("a2", .Cells(.Rows.Count,
"A").End(xlUp))
End With

With ListRange
.Sort Key1:=.Cells(1), Order1:=xlAscending, _
Header:=xlNo, OrderCustom:=1, _
MatchCase:=False, Orientation:=xlTopToBottom
End With

'check for individual City worksheets
For Each myCell In ListRange.Cells
If WksExists(myCell.Value) = False Then
Set wks = Sheets.Add
On Error Resume Next
wks.Name = myCell.Value
If Err.Number < 0 Then
MsgBox "Please rename: " & wks.Name
Err.Clear
End If
On Error GoTo 0
wks.Move after:=Sheets(Sheets.Count)
Else
Set wks = Worksheets(myCell.Value)
wks.Cells.Clear
End If

If rsp = 6 Then
DataBaseWks.Rows("1:" & i).Copy Destination:=wks.Range("A1")
End If

'change the criteria in the Criteria range
TempWks.Range("D2").Value = "=" & Chr(34) & "=" & myCell.Value
& Chr(34)

'transfer data to individual City worksheets
If rsp = 6 Then
myDatabase.AdvancedFilter _
Action:=xlFilterCopy, _
CriteriaRange:=TempWks.Range("D1:D2"), _
CopyToRange:=wks.Range("A1").Offset(i, 0), _
Unique:=False
Else
myDatabase.AdvancedFilter _
Action:=xlFilterCopy, _
CriteriaRange:=TempWks.Range("D1:D2"), _
CopyToRange:=wks.Range("A1"), _
Unique:=False
End If
Next myCell

Application.DisplayAlerts = False
TempWks.Delete
Application.DisplayAlerts = True

MsgBox "Data has been sent"
Call SetColumnWidth
Sheets("MAIN").Select
End Sub
Function WksExists(wksName As String) As Boolean
On Error Resume Next
WksExists = CBool(Len(Worksheets(wksName).Name) 0)
End Function

I can mail the JPG files to someone who wish to help me out
Can anybody help me out please?

TIA

RashidKhan

--
Debra Dalgleish
Contextureshttp://www.contextures.com/tiptech.html- Hide quoted text -

- Show quoted text -

Hello Debra,
Thanks for your prompt response. This is the sample format

A Code

B Party Name

C Inv Date

D Inv Amt

E Pmt Date

F Pmt Amt

G Balance (Formula is D - F)

There are 2 Sheets viz Main& Customers. After I run the code Data from
Columns C and D from Main Sheet is repeated on the extracted Sheet in
Columns E and F respectively.
As you may be aware that the entries are not contiguous and the new
worksheet is created according to Column A names of Main Sheet. I need
to have the individual worksheet created according to the names in
Column A and the data from C and D should not be repeated in E and F

Does this gives you some clue?
Rashid Khan

It doesn't give me a clue.

But I'm wondering if you have formulas in those cells--and maybe the formula is
not working correctly?

If you create a test workbook and convert all the formulas to values, what
happens when you run the code?



wrote:

On Feb 15, 6:00 am, Debra Dalgleish wrote:
If you post a bit of your sample data, and examples of what's being
duplicated, someone may be able to help.





wrote:
Hello All,
I am using Windows XP/Office 2003 and have the following problem

I have downloaded a file from Debra Dalgleish's Web Sitewww.contexture.com(File
Name:AdvFilterCity.Zip) and tried to change it to suit my needs.

But I have few problems with it...as shown in the JPG files viz. Before
and After.
(I have made JPG files)

The File name "Before" shows the actual entry and the File name
"After" shows when the macro FilterCities is run.

As can be seen in the file "After" in Columns F & G ...same data is
repeated from columns C & D. This is what is going wrong.

When the macro FilterCities is run I need to have the entire row
(Columns A to H) copied one below other as shown in File "Before"

Following is the macro

Option Explicit

Sub FilterCities()

Dim myCell As Range
Dim wks As Worksheet
Dim DataBaseWks As Worksheet
Dim ListRange As Range
Dim dummyRng As Range
Dim myDatabase As Range
Dim TempWks As Worksheet
Dim rsp As Integer
Dim i As Long

'include bottom most header row
Const TopLeftCellOfDataBase As String = "A4"

'what column has your key values
Const KeyColumn As String = "A"

'where's your data
Set DataBaseWks = Worksheets("Main")
i = DataBaseWks.Range(TopLeftCellOfDataBase).Row - 1

rsp = MsgBox("Include headings?", vbYesNo, "Headings")

Set TempWks = Worksheets.Add

With DataBaseWks
Set dummyRng = .UsedRange
Set myDatabase = .Range(TopLeftCellOfDataBase, _
.Cells.SpecialCells(xlCellTypeLastCell))
End With

'rebuild the List
With DataBaseWks
Intersect(myDatabase, .Columns(KeyColumn)).AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=TempWks.Range("A1"), _
Unique:=True

'Add the heading to the criteria area
TempWks.Range("D1").Value = _
.Cells(.Range(TopLeftCellOfDataBase).Row, KeyColumn).Value
End With

With TempWks
Set ListRange = .Range("a2", .Cells(.Rows.Count,
"A").End(xlUp))
End With

With ListRange
.Sort Key1:=.Cells(1), Order1:=xlAscending, _
Header:=xlNo, OrderCustom:=1, _
MatchCase:=False, Orientation:=xlTopToBottom
End With

'check for individual City worksheets
For Each myCell In ListRange.Cells
If WksExists(myCell.Value) = False Then
Set wks = Sheets.Add
On Error Resume Next
wks.Name = myCell.Value
If Err.Number < 0 Then
MsgBox "Please rename: " & wks.Name
Err.Clear
End If
On Error GoTo 0
wks.Move after:=Sheets(Sheets.Count)
Else
Set wks = Worksheets(myCell.Value)
wks.Cells.Clear
End If

If rsp = 6 Then
DataBaseWks.Rows("1:" & i).Copy Destination:=wks.Range("A1")
End If

'change the criteria in the Criteria range
TempWks.Range("D2").Value = "=" & Chr(34) & "=" & myCell.Value
& Chr(34)

'transfer data to individual City worksheets
If rsp = 6 Then
myDatabase.AdvancedFilter _
Action:=xlFilterCopy, _
CriteriaRange:=TempWks.Range("D1:D2"), _
CopyToRange:=wks.Range("A1").Offset(i, 0), _
Unique:=False
Else
myDatabase.AdvancedFilter _
Action:=xlFilterCopy, _
CriteriaRange:=TempWks.Range("D1:D2"), _
CopyToRange:=wks.Range("A1"), _
Unique:=False
End If
Next myCell

Application.DisplayAlerts = False
TempWks.Delete
Application.DisplayAlerts = True

MsgBox "Data has been sent"
Call SetColumnWidth
Sheets("MAIN").Select
End Sub
Function WksExists(wksName As String) As Boolean
On Error Resume Next
WksExists = CBool(Len(Worksheets(wksName).Name) 0)
End Function

I can mail the JPG files to someone who wish to help me out
Can anybody help me out please?

TIA

RashidKhan

--
Debra Dalgleish
Contextureshttp://www.contextures.com/tiptech.html- Hide quoted text -

- Show quoted text -

Hello Debra,
Thanks for your prompt response. This is the sample format

A Code

B Party Name

C Inv Date

D Inv Amt

E Pmt Date

F Pmt Amt

G Balance (Formula is D - F)

There are 2 Sheets viz Main& Customers. After I run the code Data from
Columns C and D from Main Sheet is repeated on the extracted Sheet in
Columns E and F respectively.
As you may be aware that the entries are not contiguous and the new
worksheet is created according to Column A names of Main Sheet. I need
to have the individual worksheet created according to the names in
Column A and the data from C and D should not be repeated in E and F

Does this gives you some clue?
Rashid Khan

--

Dave Peterson

It looks fine to me too. Maybe something is happening in the
SetColumnWidth procedure.


wrote:
On Feb 15, 6:00 am, Debra Dalgleish wrote:

If you post a bit of your sample data, and examples of what's being
duplicated, someone may be able to help.





wrote:

Hello All,
I am using Windows XP/Office 2003 and have the following problem

I have downloaded a file from Debra Dalgleish's Web Sitewww.contexture.com(File
Name:AdvFilterCity.Zip) and tried to change it to suit my needs.

But I have few problems with it...as shown in the JPG files viz. Before
and After.
(I have made JPG files)

The File name "Before" shows the actual entry and the File name
"After" shows when the macro FilterCities is run.

As can be seen in the file "After" in Columns F & G ...same data is
repeated from columns C & D. This is what is going wrong.

When the macro FilterCities is run I need to have the entire row
(Columns A to H) copied one below other as shown in File "Before"

Following is the macro

Option Explicit

Sub FilterCities()

Dim myCell As Range
Dim wks As Worksheet
Dim DataBaseWks As Worksheet
Dim ListRange As Range
Dim dummyRng As Range
Dim myDatabase As Range
Dim TempWks As Worksheet
Dim rsp As Integer
Dim i As Long

'include bottom most header row
Const TopLeftCellOfDataBase As String = "A4"

'what column has your key values
Const KeyColumn As String = "A"

'where's your data
Set DataBaseWks = Worksheets("Main")
i = DataBaseWks.Range(TopLeftCellOfDataBase).Row - 1

rsp = MsgBox("Include headings?", vbYesNo, "Headings")

Set TempWks = Worksheets.Add

With DataBaseWks
Set dummyRng = .UsedRange
Set myDatabase = .Range(TopLeftCellOfDataBase, _
.Cells.SpecialCells(xlCellTypeLastCell))
End With

'rebuild the List
With DataBaseWks
Intersect(myDatabase, .Columns(KeyColumn)).AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=TempWks.Range("A1"), _
Unique:=True

'Add the heading to the criteria area
TempWks.Range("D1").Value = _
.Cells(.Range(TopLeftCellOfDataBase).Row, KeyColumn).Value
End With

With TempWks
Set ListRange = .Range("a2", .Cells(.Rows.Count,
"A").End(xlUp))
End With

With ListRange
.Sort Key1:=.Cells(1), Order1:=xlAscending, _
Header:=xlNo, OrderCustom:=1, _
MatchCase:=False, Orientation:=xlTopToBottom
End With

'check for individual City worksheets
For Each myCell In ListRange.Cells
If WksExists(myCell.Value) = False Then
Set wks = Sheets.Add
On Error Resume Next
wks.Name = myCell.Value
If Err.Number < 0 Then
MsgBox "Please rename: " & wks.Name
Err.Clear
End If
On Error GoTo 0
wks.Move after:=Sheets(Sheets.Count)
Else
Set wks = Worksheets(myCell.Value)
wks.Cells.Clear
End If

If rsp = 6 Then
DataBaseWks.Rows("1:" & i).Copy Destination:=wks.Range("A1")
End If

'change the criteria in the Criteria range
TempWks.Range("D2").Value = "=" & Chr(34) & "=" & myCell.Value
& Chr(34)

'transfer data to individual City worksheets
If rsp = 6 Then
myDatabase.AdvancedFilter _
Action:=xlFilterCopy, _
CriteriaRange:=TempWks.Range("D1:D2"), _
CopyToRange:=wks.Range("A1").Offset(i, 0), _
Unique:=False
Else
myDatabase.AdvancedFilter _
Action:=xlFilterCopy, _
CriteriaRange:=TempWks.Range("D1:D2"), _
CopyToRange:=wks.Range("A1"), _
Unique:=False
End If
Next myCell

Application.DisplayAlerts = False
TempWks.Delete
Application.DisplayAlerts = True

MsgBox "Data has been sent"
Call SetColumnWidth
Sheets("MAIN").Select
End Sub
Function WksExists(wksName As String) As Boolean
On Error Resume Next
WksExists = CBool(Len(Worksheets(wksName).Name) 0)
End Function

I can mail the JPG files to someone who wish to help me out
Can anybody help me out please?

TIA

RashidKhan

--
Debra Dalgleish
Contextureshttp://www.contextures.com/tiptech.html- Hide quoted text -

- Show quoted text -


Hello Debra,
Thanks for your prompt response. This is the sample format

A Code

B Party Name

C Inv Date

D Inv Amt

E Pmt Date

F Pmt Amt

G Balance (Formula is D - F)

There are 2 Sheets viz Main& Customers. After I run the code Data from
Columns C and D from Main Sheet is repeated on the extracted Sheet in
Columns E and F respectively.
As you may be aware that the entries are not contiguous and the new
worksheet is created according to Column A names of Main Sheet. I need
to have the individual worksheet created according to the names in
Column A and the data from C and D should not be repeated in E and F

Does this gives you some clue?
Rashid Khan



--
Debra Dalgleish
Contextures
http://www.contextures.com/tiptech.html

On Feb 15, 8:58 pm, Debra Dalgleish wrote:
It looks fine to me too. Maybe something is happening in the
SetColumnWidth procedure.





wrote:
On Feb 15, 6:00 am, Debra Dalgleish wrote:

If you post a bit of your sample data, and examples of what's being
duplicated, someone may be able to help.

wrote:

Hello All,
I am using Windows XP/Office 2003 and have the following problem

I have downloaded a file from Debra Dalgleish's Web Sitewww.contexture.com(File
Name:AdvFilterCity.Zip) and tried to change it to suit my needs.

But I have few problems with it...as shown in the JPG files viz. Before
and After.
(I have made JPG files)

The File name "Before" shows the actual entry and the File name
"After" shows when the macro FilterCities is run.

As can be seen in the file "After" in Columns F & G ...same data is
repeated from columns C & D. This is what is going wrong.

When the macro FilterCities is run I need to have the entire row
(Columns A to H) copied one below other as shown in File "Before"

Following is the macro

Option Explicit

Sub FilterCities()

Dim myCell As Range
Dim wks As Worksheet
Dim DataBaseWks As Worksheet
Dim ListRange As Range
Dim dummyRng As Range
Dim myDatabase As Range
Dim TempWks As Worksheet
Dim rsp As Integer
Dim i As Long

'include bottom most header row
Const TopLeftCellOfDataBase As String = "A4"

'what column has your key values
Const KeyColumn As String = "A"

'where's your data
Set DataBaseWks = Worksheets("Main")
i = DataBaseWks.Range(TopLeftCellOfDataBase).Row - 1

rsp = MsgBox("Include headings?", vbYesNo, "Headings")

Set TempWks = Worksheets.Add

With DataBaseWks
Set dummyRng = .UsedRange
Set myDatabase = .Range(TopLeftCellOfDataBase, _
.Cells.SpecialCells(xlCellTypeLastCell))
End With

'rebuild the List
With DataBaseWks
Intersect(myDatabase, .Columns(KeyColumn)).AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=TempWks.Range("A1"), _
Unique:=True

'Add the heading to the criteria area
TempWks.Range("D1").Value = _
.Cells(.Range(TopLeftCellOfDataBase).Row, KeyColumn).Value
End With

With TempWks
Set ListRange = .Range("a2", .Cells(.Rows.Count,
"A").End(xlUp))
End With

With ListRange
.Sort Key1:=.Cells(1), Order1:=xlAscending, _
Header:=xlNo, OrderCustom:=1, _
MatchCase:=False, Orientation:=xlTopToBottom
End With

'check for individual City worksheets
For Each myCell In ListRange.Cells
If WksExists(myCell.Value) = False Then
Set wks = Sheets.Add
On Error Resume Next
wks.Name = myCell.Value
If Err.Number < 0 Then
MsgBox "Please rename: " & wks.Name
Err.Clear
End If
On Error GoTo 0
wks.Move after:=Sheets(Sheets.Count)
Else
Set wks = Worksheets(myCell.Value)
wks.Cells.Clear
End If

If rsp = 6 Then
DataBaseWks.Rows("1:" & i).Copy Destination:=wks.Range("A1")
End If

'change the criteria in the Criteria range
TempWks.Range("D2").Value = "=" & Chr(34) & "=" & myCell.Value
& Chr(34)

'transfer data to individual City worksheets
If rsp = 6 Then
myDatabase.AdvancedFilter _
Action:=xlFilterCopy, _
CriteriaRange:=TempWks.Range("D1:D2"), _
CopyToRange:=wks.Range("A1").Offset(i, 0), _
Unique:=False
Else
myDatabase.AdvancedFilter _
Action:=xlFilterCopy, _
CriteriaRange:=TempWks.Range("D1:D2"), _
CopyToRange:=wks.Range("A1"), _
Unique:=False
End If
Next myCell

Application.DisplayAlerts = False
TempWks.Delete
Application.DisplayAlerts = True

MsgBox "Data has been sent"
Call SetColumnWidth
Sheets("MAIN").Select
End Sub
Function WksExists(wksName As String) As Boolean
On Error Resume Next
WksExists = CBool(Len(Worksheets(wksName).Name) 0)
End Function

I can mail the JPG files to someone who wish to help me out
Can anybody help me out please?

TIA

RashidKhan

--
Debra Dalgleish
Contextureshttp://www.contextures.com/tiptech.html-Hide quoted text -

- Show quoted text -

Hello Debra,
Thanks for your prompt response. This is the sample format

A Code

B Party Name

C Inv Date

D Inv Amt

E Pmt Date

F Pmt Amt

G Balance (Formula is D - F)

There are 2 Sheets viz Main& Customers. After I run the code Data from
Columns C and D from Main Sheet is repeated on the extracted Sheet in
Columns E and F respectively.
As you may be aware that the entries are not contiguous and the new
worksheet is created according to Column A names of Main Sheet. I need
to have the individual worksheet created according to the names in
Column A and the data from C and D should not be repeated in E and F

Does this gives you some clue?
RashidKhan

--
Debra Dalgleish
Contextureshttp://www.contextures.com/tiptech.html- Hide quoted text -

- Show quoted text -

Thanks Dave and Debra
Dave...There are no formulas in any of the columns except in Column G
Debra...I am giving the macro Setwidth for your reference

Sub SetColumnWidth()
Dim WS As Worksheet
Application.EnableEvents = False


For Each WS In Worksheets
WS.Columns.AutoFit
Next
Application.EnableEvents = True
End Sub

Thanks both of you for your prompt attention
Rashid Khan

Do you have the same result if you delete all the destination sheets,
and run the macro?

wrote:
On Feb 15, 8:58 pm, Debra Dalgleish wrote:

It looks fine to me too. Maybe something is happening in the
SetColumnWidth procedure.





wrote:

On Feb 15, 6:00 am, Debra Dalgleish wrote:

If you post a bit of your sample data, and examples of what's being
duplicated, someone may be able to help.

wrote:

Hello All,
I am using Windows XP/Office 2003 and have the following problem

I have downloaded a file from Debra Dalgleish's Web Sitewww.contexture.com(File
Name:AdvFilterCity.Zip) and tried to change it to suit my needs.

But I have few problems with it...as shown in the JPG files viz. Before
and After.
(I have made JPG files)

The File name "Before" shows the actual entry and the File name
"After" shows when the macro FilterCities is run.

As can be seen in the file "After" in Columns F & G ...same data is
repeated from columns C & D. This is what is going wrong.

When the macro FilterCities is run I need to have the entire row
(Columns A to H) copied one below other as shown in File "Before"

Following is the macro

Option Explicit

Sub FilterCities()

Dim myCell As Range
Dim wks As Worksheet
Dim DataBaseWks As Worksheet
Dim ListRange As Range
Dim dummyRng As Range
Dim myDatabase As Range
Dim TempWks As Worksheet
Dim rsp As Integer
Dim i As Long

'include bottom most header row
Const TopLeftCellOfDataBase As String = "A4"

'what column has your key values
Const KeyColumn As String = "A"

'where's your data
Set DataBaseWks = Worksheets("Main")
i = DataBaseWks.Range(TopLeftCellOfDataBase).Row - 1

rsp = MsgBox("Include headings?", vbYesNo, "Headings")

Set TempWks = Worksheets.Add

With DataBaseWks
Set dummyRng = .UsedRange
Set myDatabase = .Range(TopLeftCellOfDataBase, _
.Cells.SpecialCells(xlCellTypeLastCell))
End With

'rebuild the List
With DataBaseWks
Intersect(myDatabase, .Columns(KeyColumn)).AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=TempWks.Range("A1"), _
Unique:=True

'Add the heading to the criteria area
TempWks.Range("D1").Value = _
.Cells(.Range(TopLeftCellOfDataBase).Row, KeyColumn).Value
End With

With TempWks
Set ListRange = .Range("a2", .Cells(.Rows.Count,
"A").End(xlUp))
End With

With ListRange
.Sort Key1:=.Cells(1), Order1:=xlAscending, _
Header:=xlNo, OrderCustom:=1, _
MatchCase:=False, Orientation:=xlTopToBottom
End With

'check for individual City worksheets
For Each myCell In ListRange.Cells
If WksExists(myCell.Value) = False Then
Set wks = Sheets.Add
On Error Resume Next
wks.Name = myCell.Value
If Err.Number < 0 Then
MsgBox "Please rename: " & wks.Name
Err.Clear
End If
On Error GoTo 0
wks.Move after:=Sheets(Sheets.Count)
Else
Set wks = Worksheets(myCell.Value)
wks.Cells.Clear
End If

If rsp = 6 Then
DataBaseWks.Rows("1:" & i).Copy Destination:=wks.Range("A1")
End If

'change the criteria in the Criteria range
TempWks.Range("D2").Value = "=" & Chr(34) & "=" & myCell.Value
& Chr(34)

'transfer data to individual City worksheets
If rsp = 6 Then
myDatabase.AdvancedFilter _
Action:=xlFilterCopy, _
CriteriaRange:=TempWks.Range("D1:D2"), _
CopyToRange:=wks.Range("A1").Offset(i, 0), _
Unique:=False
Else
myDatabase.AdvancedFilter _
Action:=xlFilterCopy, _
CriteriaRange:=TempWks.Range("D1:D2"), _
CopyToRange:=wks.Range("A1"), _
Unique:=False
End If
Next myCell

Application.DisplayAlerts = False
TempWks.Delete
Application.DisplayAlerts = True

MsgBox "Data has been sent"
Call SetColumnWidth
Sheets("MAIN").Select
End Sub
Function WksExists(wksName As String) As Boolean
On Error Resume Next
WksExists = CBool(Len(Worksheets(wksName).Name) 0)
End Function

I can mail the JPG files to someone who wish to help me out
Can anybody help me out please?

TIA

RashidKhan

--
Debra Dalgleish
Contextureshttp://www.contextures.com/tiptech.html-Hide quoted text -

- Show quoted text -

Hello Debra,
Thanks for your prompt response. This is the sample format

A Code

B Party Name

C Inv Date

D Inv Amt

E Pmt Date

F Pmt Amt

G Balance (Formula is D - F)

There are 2 Sheets viz Main& Customers. After I run the code Data from
Columns C and D from Main Sheet is repeated on the extracted Sheet in
Columns E and F respectively.
As you may be aware that the entries are not contiguous and the new
worksheet is created according to Column A names of Main Sheet. I need
to have the individual worksheet created according to the names in
Column A and the data from C and D should not be repeated in E and F

Does this gives you some clue?
RashidKhan

--
Debra Dalgleish
Contextureshttp://www.contextures.com/tiptech.html- Hide quoted text -

- Show quoted text -


Thanks Dave and Debra
Dave...There are no formulas in any of the columns except in Column G
Debra...I am giving the macro Setwidth for your reference

Sub SetColumnWidth()
Dim WS As Worksheet
Application.EnableEvents = False


For Each WS In Worksheets
WS.Columns.AutoFit
Next
Application.EnableEvents = True
End Sub

Thanks both of you for your prompt attention
Rashid Khan




--
Debra Dalgleish
Contextures
http://www.contextures.com/tiptech.html