Help with Debra Dalgleish's Code

  • Thread starter Thread starter prkhan56
  • Start date Start date
P

prkhan56

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.
 
If you post a bit of your sample data, and examples of what's being
duplicated, someone may be able to help.

































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

- Show quoted text -
Click to expand...

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?
 
It looks fine to me too. Maybe something is happening in the
SetColumnWidth procedure.
 
It looks fine to me too. Maybe something is happening in the
SetColumnWidth procedure.

















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

- Show quoted text -
Click to expand...

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?
 
Do you have the same result if you delete all the destination sheets,
and run the macro?











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

- Show quoted text -
Click to expand...

Hi Debra,
Yes I do, when I run the macro that time I have only Main and
Customers only...and when the individual sheets are created data from
Columns C & D is
repeated from columns F & G respectively. This is what is going
wrong.
Thanks for your time and help
Rashid Khan
 
Hi Debra,
Yes I do, when I run the macro that time I have only Main and
Customers only...and when the individual sheets are created data from
Columns C & D is
repeated from columns F & G respectively. This is what is going
wrong.
Thanks for your time and helpRashidKhan- Hide quoted text -

- Show quoted text -
Click to expand...

Sorry a typo in the previous post...Data from C and D is repeated in F
and G respectively...
Thanks
 
If you create a new test worksheet--brand new and populate it with test data,
does the routine work ok?
 
If you create a new test worksheet--brand new and populate it with test data,
does the routine work ok?

(e-mail address removed) wrote:

<<snipped>>









--

Dave Peterson- Hide quoted text -

- Show quoted text -
Click to expand...

Hello Dave,
I created a brand new worksheet and run the code..
Unfortunately same result is given

Thanks for your time
Rashid Khan
 
Try stepping through the code. After each "major" step, go back to excel and
look to see if things look ok.

When you process a line that screws up the data, you'll know what's causing the
trouble.
 
Try stepping through the code. After each "major" step, go back to excel and
look to see if things look ok.

When you process a line that screws up the data, you'll know what's causing the
trouble.









--

Dave Peterson- Hide quoted text -

- Show quoted text -
Click to expand...

Hello Dave,
I run the routine and following lines is giving problem:

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
When the above code is run the data from Columns C & D is repeated in
Columns F & G respectively on the individual sheets.
Thanks for your time and assistance

Rashid Khan
 
Do you have any duplicated headers in your data? If you do, change them so each
header is unique.
 
Do you have any duplicated headers in your data? If you do, change them so each
header is unique.










--

Dave Peterson- Hide quoted text -

- Show quoted text -
Click to expand...

Hi Dave,
Voila....that was it... I changed the header and it works
perfectly...Thanks a million for your help.

You once again saved my day

Rashid Khan
 
One favor.

You may have noticed that in the ms excel newsgroups, most people put their
replies at the top.

You may want to start doing this while you're in these newsgroups.

(Yep. Other (most??) newsgroups follow bottom posting and snipping. We're
different here <bg>.)
 
Hello Dave,
Sorry for my ignorance. Thanks for guiding me. I would take care in
my future postings.
Rashid Khan
 
Thanks! Glad you figured it out. I've added a note to the sample file,
mentioning that the headings must be unique.
 
Back
Top