problems with advanced filters

[vincent trouche]

Hi everybody,

I've been scratching my head very hard to solve this problem. First I
will give you the code, then I will explain my problem.

1/ the code - the objective is to take the values from 3 differents
columns of the sheet "data" (column 13 (M), 32(AF), 33(AG)) and put them
in 1 column of the sheet agenda.

Dim rng as range

With Sheets("data") 'CA
Set rng = .Range(.Cells(1, 13), .Cells(Rows.Count, 13).End(xlUp))
End With

rng.Advancedfilter Action:=xlFilterCopy, _
CopyToRange:=Sheets("agenda").Range("A1"), Unique:=True

MsgBox "ok CA"
cLastRow = Worksheets("agenda").Cells(Rows.Count, "A").End(xlUp).Row
MsgBox cLastRow

With Sheets("data") 'Assigned investigator
Set rng = .Range(.Cells(2, 32), .Cells(Rows.Count, 32).End(xlUp)) 'i put
cell 2 not to catch label
End With

rng.Advancedfilter Action:=xlFilterCopy, _
CopyToRange:=Sheets("agenda").Range("A" & cLastRow + 1), Unique:=True

MsgBox "ok assigned"
cLastRow = Worksheets("agenda").Cells(Rows.Count, "A").End(xlUp).Row
MsgBox cLastRow

With Sheets("data") 'Actual investigator
Set rng = .Range(.Cells(2, 33), .Cells(Rows.Count, 33).End(xlUp))
End With

'If rng.Cells.Count < 2 Then Exit Sub

rng.Advancedfilter Action:=xlFilterCopy, _
CopyToRange:=Sheets("agenda").Range("A" & cLastRow + 1), Unique:=True

MsgBox "ok actual"
cLastRow = Worksheets("agenda").Cells(Rows.Count, "A").End(xlUp).Row
MsgBox cLastRow

With Sheets("agenda") 'keep only the unique values
Set rng = .Range(.Cells(1, 1), .Cells(Rows.Count, 1).End(xlUp))
End With

rng.Advancedfilter Action:=xlFilterCopy, _
CopyToRange:=Sheets("agenda").Range("B1"), Unique:=True

MsgBox "ok unique"
cLastRow = Worksheets("agenda").Cells(Rows.Count, "B").End(xlUp).Row
MsgBox cLastRow

2/ My problem : this code works fine except for one thing : I can't
paste the 3rd column of my data. There simply nothing that is paste in
my agenda sheet!!

Any ideas why/ or ideas to fix this problem???

You'll remark that the code to paste the 3 columns from the "data" sheet
is more or less 3 time the same thing so I just don't understand why it
doesn't work...

Any help will apreciated very, very much...

Vincent

Philadelphia, USA.


*** Sent via Developersdex http://www.developersdex.com ***
Don't just participate in USENET...get rewarded for it!

 

[Dave Peterson]

Your code worked ok for me against my test data.

You wrote that you wanted to start in row 2 to avoid the headers. But you have
to include one row of headers for advanced filter to work (correctly).

You could put it in and then come back and remove that header.

worksheets("agenda").rows(clastrow+1).delete
right after you do the advanced filter.

And if you're trying to get one list of all the unique values in the list (it
kind of looks that way when you do your last filter in column B, maybe you could
just copy the cells and paste (no real sense to get unique entries 3 times, just
to run it once more).

Well, as long as the total number of rows used is less than 65k.

 

[vincent trouche]

Thanks for your answer Dave.

Well it makes a lot of sense just to paste before performing an advanced
filter from column A to column B. But then I got a problem with the
paste fonction : Run time error '1004' Info cannot be pasted because
copy area and paste area are not the same size...

After some research on this newsgroup here is the right way to put 3
columns into one column and keep only the unique values without too much
hassle :

Dim rng As Range
Dim rnga As Range
Dim rngb As Range
Dim rng2 As Range
Dim cLastRow As Integer
Dim nbligne As Integer

nbligne = Worksheets("Data").Cells(Rows.Count, "AG").End(xlUp).Row

MsgBox nbligne

Sheets("agenda").Columns(1).ClearContents

Sheets("Data").Select
Columns("M:M").Select
Selection.Copy
Sheets("agenda").Select
Range("A1").Select
ActiveSheet.Paste

MsgBox "ok CA"
cLastRow = Worksheets("agenda").Cells(Rows.Count, "A").End(xlUp).Row
MsgBox cLastRow


Sheets("Data").Select
Range("AF1:AF" & Range("A65536").End(xlUp).Row).Copy
Sheets("agenda").Select
Range("A" & cLastRow + 1).Select
ActiveSheet.Paste
Worksheets("agenda").Rows(cLastRow + 1).Delete

MsgBox "ok assigned"
cLastRow = Worksheets("agenda").Cells(Rows.Count, "A").End(xlUp).Row
MsgBox cLastRow


Sheets("Data").Select
Range("AG1:AG" & Range("A65536").End(xlUp).Row).Copy
Sheets("agenda").Select
Range("A" & cLastRow + 1).Select
ActiveSheet.Paste
Worksheets("agenda").Rows(cLastRow + 1).Delete

MsgBox "ok actual"
cLastRow = Worksheets("agenda").Cells(Rows.Count, "A").End(xlUp).Row
MsgBox cLastRow

With Sheets("agenda")
Set rng = .Range(.Cells(1, 1), .Cells(Rows.Count, 1).End(xlUp))
End With
rng.Advancedfilter Action:=xlFilterCopy, _
CopyToRange:=Sheets("agenda").Range("B1"), Unique:=True

MsgBox "ok unique"
cLastRow = Worksheets("agenda").Cells(Rows.Count, "B").End(xlUp).Row
MsgBox cLastRow


*** Sent via Developersdex http://www.developersdex.com ***
Don't just participate in USENET...get rewarded for it!

 

[Dave Peterson]

I bet you tried to copy the whole column and couldn't do that a second time.

But sometimes, it's easier to use a loop--especially for code that's almost
identical.

(And I'd use Long's, not Integer's)

Anyway...

Option Explicit
Sub testme02()

Dim rng As Range
Dim dataWks As Worksheet
Dim AgendaWks As Worksheet
Dim DestCell As Range

Dim ColsToCopy As Variant
Dim iCtr As Long

ColsToCopy = Array("M", "AF", "AG")

Set dataWks = Worksheets("data")
Set AgendaWks = Worksheets("agenda")

with AgendaWks
.Range("a:b").ClearContents
'add that header
.Range("a1").Value = dataWks.Cells(1, ColsToCopy(1)).Value
end with

With dataWks
For iCtr = LBound(ColsToCopy) To UBound(ColsToCopy)
With AgendaWks
Set DestCell = .Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0)
End With
Set rng = .Range(.Cells(2, ColsToCopy(iCtr)), _
.Cells(.Rows.Count, ColsToCopy(iCtr)).End(xlUp))

If DestCell.Row + rng.Rows.Count > .Rows.Count Then
'not enough room
MsgBox "too many rows"
Exit Sub
End If
rng.Copy _
Destination:=DestCell
Next iCtr
End With

With AgendaWks
.Range("a:a").AdvancedFilter Action:=xlFilterCopy, _
CopyToRange:=.Range("B1"), Unique:=True
End With

End Sub