Hlp! Adv Filter - Non-Contiguous rows don't copy

[Joyce]

Hello,

I apply an advanced filter to data on Sht1 and then select the first few
columns of the filtered data and run the following macro to copy to Sht2.

All works well for 1 row, or for contiguous rows. However, when the results
are non-contiguous rows, it doesn't work at all.

Any help would be greatly appreciated: Here is my code:

Dim rng As Range, i As Long
Selection.SpecialCells(xlCellTypeVisible).Select
Set rng = Selection
rng.Select


i = rng.Rows.Count
If i = 1 Then
rng.Copy
Application.Goto Reference:="TrDate"
ActiveCell.Offset(1, 0).Range("A1").Select
ActiveSheet.Paste
ActiveCell.Offset(0, 1).Range("A1:B1").Select
Application.CutCopyMode = False
Selection.Delete Shift:=xlToLeft
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone

With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
Selection.Borders(xlInsideVertical).LineStyle = xlNone
Application.Goto Reference:="SpecDate"


Else
rng.Copy
Application.Goto Reference:="SpecDate"
ActiveCell.Offset(1, 0).Range("A1").Select
Selection.Insert Shift:=xlDown
ActiveCell.Offset(0, 1).Range("A1:B1").Select
Range(Selection, Selection.End(xlDown)).Select
Application.CutCopyMode = False
Selection.Delete Shift:=xlToLeft
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone

With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
Selection.Borders(xlInsideVertical).LineStyle = xlNone
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
Selection.RowHeight = 27
ActiveCell.Offset(0, -1).Range("A1").Select
Selection.End(xlDown).Select
ActiveCell.Offset(1, 0).Rows("1:1").EntireRow.Select
Selection.Delete Shift:=xlUp
Selection.RowHeight = 27


End If

 

[Dave Peterson]

When you use this line:
i = rng.Rows.Count
i isn't the number of rows in rng. It's the number of rows in the first area of
that range.

If you want to see how many rows are in that range, I'd use:

i = rng.columns(1).cells.count

 

[Joyce]

Hi Dave,

I made your suggested change - thanks.

However, it still doesn't work when I filter my date, then select the first
4 columns of filtered data and run the macro when the data I select resides
on non-contiguous rows.

My goal is to copy the first 4 columns of data, then remove the 2nd and 3rd
columns (I only need to pull data from columns 1 and 4).

It works fine when 1 singular row or contiguous rows are the result of the
advanced filter; the minute they are non-contiguous - no longer works.

Thanks

 

[Dave Peterson]

Without the formatting...

And I like to specify where I want to paste--worksheet and range name.

I did assume that both SpecDate and TrData are single cells.

Option Explicit
Sub testme02()

Dim VisRng As Range
Dim HowManyVisible As Long
Dim myRng As Range
Dim DestCell As Range

Set myRng = Selection

HowManyVisible = myRng.Columns(1) _
.SpecialCells(xlCellTypeVisible).Cells.Count

Set VisRng = myRng.Cells.SpecialCells(xlCellTypeVisible)

If HowManyVisible = 1 Then
Set DestCell = Worksheets("Sheet2").Range("trdate").Offset(1, 0)
Else
Set DestCell = Worksheets("sheet3").Range("SpecDate").Offset(1, 0)
End If

VisRng.Copy _
Destination:=DestCell

With DestCell
.Resize(HowManyVisible, 2).Offset(0, 1).Delete shift:=xlToLeft
End With

End Sub

 

[Joyce]

Hi Dave,

That worked really well, with one exception.

It doesn't push the data beneath the destination down; instead it replaced
it (wrote over it).

Almost there

Thanks!

 

[Dave Peterson]

I missed that in your code.

I inserted entirerows--is that ok:

Option Explicit
Sub testme02()

Dim VisRng As Range
Dim HowManyVisible As Long
Dim myRng As Range
Dim LastCell As Range

Set myRng = Selection

HowManyVisible _
= myRng.Columns(1).SpecialCells(xlCellTypeVisible).Cells.Count

Set VisRng = myRng.Cells.SpecialCells(xlCellTypeVisible)

If HowManyVisible = 1 Then
Set LastCell = Worksheets("Sheet2").Range("trdate")
Else
Set LastCell = Worksheets("sheet3").Range("SpecDate")
End If

LastCell.Offset(1, 0).Resize(HowManyVisible, 1).EntireRow.Insert

VisRng.Copy _
Destination:=LastCell.Offset(1, 0)

With LastCell.Offset(1, 0)
.Resize(HowManyVisible, 2).Offset(0, 1).Delete shift:=xlToLeft
End With

End Sub

 

[Joyce]

Hi Dave,

This is working very well and is *much* cleaner than my mess

I have a few questions, if you wouldn't mind:

1. Would you mind breaking down the Resize with Offset that removes the
extra columns in the pasted data? What dictates that columns 1 and 4 will
stay and columns 2 and 3 will be removed? I'd like to better understand this.

2. One last thing I need to do (which would eliminate all of the formatting
code) is select the blank row that ends up beneath the newly pasted data,
copy the row formatting (row height, borders, etc. - all that would be copied
when selecting a row, clicking the Format Painter, and dragging over
destination rows).

3. I would then like to delete the row from which I copied the formatting.

Thank you so much for your time and effort.

 

[Joyce]

Hello again,

I'm also trying to remove a step from the user that would force them to
select the first 4 columns of rows displayed as a result of the advanced
filter.

I'm trying (unsuccessfully) to begin the macro with selecting the dynamic
range name called FilteredData (that includes only the first 4 columns)
visible cells only.

I keep getting errors. I'm trying:

Range("FilteredData").Select
Selection.SpecialCells(xlCellTypeVisible).Cells.Select


Thanks.

 

[Dave Peterson]

#1. For example:

LastCell.Offset(1, 0).Resize(HowManyVisible, 1).EntireRow.Insert
Lastcell is either the TRData or SpecData cell.
..offset(1,0) says to go down one row and over 0 columns.

You use positive offsets to go down or to the right.
You use negative offsets to go up or to the left.
If the offset is 0 (or not used), then it stays in the same row or column.

msgbox Range("a1").offset(12,52).address
says to go down 12 rows and 52 columns to the right.

The resize says that no matter what the range is refering to right then, you
want it to be resized, er, changed to a different size.

Range("A1") is one cell.
range("A1").resize(22,32) is now a range of 22 rows x 32 columns--with its
topleft corner still in A1.

Range("A1").offset(12,52).resize(22,32) is now 22 rows x 32 columns. But it's
topleft corner is now 12 rows under A1 and 52 columns to the right.

My question to you is what do expect to see when you use:
msgbox Range("A1").offset(12,52).resize(22,32).address
and
msgbox Range("A1").resize(22,32).offset(12,52).address
Did it match your expectation?

And what happens if you use:
MsgBox Range("A1:x99").Resize(22, 32).Offset(12, 52).Address

====
This portion:

Says go to SpecData (say) and come down a row.
Then resize it the number of visible rows (to match the selected range)--but
make it 2 columns wide.

Then go over a column (still two columns wide, just shifted over a column
(right?)).

And delete that pair of columns.

I probably shouldn't have used the with statement:

LastCell.Offset(1, 0).Resize(HowManyVisible, 2).Offset(0, 1).Delete _
shift:=xlToLeft

should work as well.

And I thought that I was making it a little clearer by using two offsets, but I
could have used:

LastCell.Offset(1, 1).Resize(HowManyVisible, 2).Delete shift:=xlToLeft

Go to SpecData/TRData, down a row over a column, resize it to visible row count
by 2 columns and delete it shifting things to the left.

And if I was really thinking, I'd use:
LastCell.Resize(HowManyVisible, 2).Offset(1, 1).Delete shift:=xlToLeft

Sometimes, you can offset a range off the sheet. So resizing is usually a good
thing to do first.

go to specdata/trdata, make the range 2 columns by x number of rows, then over 1
and down one and shift to the left.

=========
#2.

Option Explicit
Sub testme02()

Dim VisRng As Range
Dim HowManyVisible As Long
Dim myRng As Range
Dim LastCell As Range

Set myRng = Selection

HowManyVisible _
= myRng.Columns(1).SpecialCells(xlCellTypeVisible).Cells.Count

Set VisRng = myRng.Cells.SpecialCells(xlCellTypeVisible)

If HowManyVisible = 1 Then
Set LastCell = Worksheets("Sheet2").Range("trdate")
Else
Set LastCell = Worksheets("sheet3").Range("SpecDate")
End If

LastCell.Offset(1, 0).Resize(HowManyVisible, 1).EntireRow.Insert

VisRng.Copy _
Destination:=LastCell.Offset(1, 0)

LastCell.Resize(HowManyVisible, 2).Offset(1, 1).Delete shift:=xlToLeft

LastCell.Offset(HowManyVisible + 1, 0).EntireRow.Copy
LastCell.Offset(1, 0).Resize(HowManyVisible, 1).EntireRow.PasteSpecial _
Paste:=xlPasteFormats

Application.CutCopyMode = False 'remove the dancing ants.

End Sub

 

[Dave Peterson]

Good. I hate depending on the selection--and that the correct sheet is active.

And I bet the selection never included the headers. It always started with the
first visible row through the last visible row. Right?

Option Explicit
Sub testme02()

Dim VisRng As Range
Dim HowManyVisible As Long
Dim myRng As Range
Dim LastCell As Range

With Worksheets("Sheet1")
Set myRng = .Range("_filterdatabase")
End With

'Howmanyvisible includes the header
'So we subtract 1 to count just the data
HowManyVisible _
= myRng.Columns(1).SpecialCells(xlCellTypeVisible).Cells.Count - 1

If HowManyVisible = 0 Then
MsgBox "No matching entries!"
Exit Sub
End If

With myRng
'ignore the header (resize by total rows -1 and come down one row
Set VisRng _
= .Resize(.Rows.Count - 1, 4).Offset(1, 0) _
.Cells.SpecialCells(xlCellTypeVisible)
MsgBox VisRng.Address
End With

If HowManyVisible = 1 Then
Set LastCell = Worksheets("Sheet2").Range("trdate")
Else
Set LastCell = Worksheets("sheet3").Range("SpecDate")
End If

LastCell.Offset(1, 0).Resize(HowManyVisible, 1).EntireRow.Insert

VisRng.Copy _
Destination:=LastCell.Offset(1, 0)

LastCell.Resize(HowManyVisible, 2).Offset(1, 1).Delete shift:=xlToLeft

LastCell.Offset(HowManyVisible + 1, 0).EntireRow.Copy
LastCell.Offset(1, 0).Resize(HowManyVisible, 1).EntireRow.PasteSpecial _
Paste:=xlPasteFormats

Application.CutCopyMode = False 'remove the dancing ants.

End Sub

Notice that I used:
Set myRng = .Range("_filterdatabase")
instead of using your range name.

When you use autofilter or advanced filter, excel creates a hidden name (to keep
prying fingers away from damaging it) called _filterdatabase.

So I used that instead.

Since you are working with names, do yourself a favor and get a copy of Jan
Karel Pieterse's (with Charles Williams and Matthew Henson) Name Manager:
NameManager.Zip from http://www.oaltd.co.uk/mvp

It's the best tool I've seen for working with names.

 

[Joyce]

Hello Dave,

You are one patient man! I've modified everything, including deleting the
row that the formatting was copied from and it's working beautifully.

Thank you so much for not only your assistance, but also your very clear
explanation of the code. I'm extremely familiar with Excel but not so much
VBA, so this was a great help.

I use range names and dynamic range names all the time, so have visited the
site you recommended and will download.

Thanks again, Dave.

 

[Dave Peterson]

Whew! <vbg>

Excel is a pretty powerful platform, huh?

Glad I could help.