Copy Visible cells code

[thejacko5]

Hey all,

First post here. I have been having some trouble with this code. My objectives are for it to copy columns headers (C6:XX6) that are in a database to an output sheet on the condition that the column has been autofiltered. I am using a visible cell condition because I think that will suffice for now.

The code works when every column is visible and unsorted, however, if i contract grouped columns or sort the macro fails. No error, but it just leaves blank cells where the output should be. Can anyone provide some suggestions, or examples.

TIA,


J

:banghead:

Sub Button89_Click()
Sheets("Output").Range("C501:c513,d501:d513,e501:e513").ClearContents
With Sheets("Database")
myarray = Array(502, 503, 504, 505, 506, 507, 508, 501, 502, 503, 504, 505, 506, 507, 508, 509, 510, 501, 502, 503, 504, 505, 501)
myarray2 = Array(3, 3, 3, 3, 3, 3, 3, 3, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 5, 5, 5, 5, 5)
z = 0
For i = 3 To 25
On Error Resume Next
x = Application.WorksheetFunction.CountIf(.Range(Cells(7, i), Cells(2000, i)).SpecialCells(xlVisible), "X")
If x > 0 Then
.Cells(6, i).Copy
Sheets("Output").Cells(myarray(z), myarray2(z)).PasteSpecial Transpose:=True
End If
z = z + 1
Next i
End With
End Sub

[mdmackillop]

Hi J
Welcome to VBAX
Can you post your workbook with real or dummy data? Use Manage Attachments in the Go Advanced section.
Regards
MD

[thejacko5]

i am doing my best to cut down the database in order to post it. I cant get it down to 244kb though

[mdmackillop]

You can zip it if required.

[thejacko5]

ok, I have attached the file.

This is a fairly chopped down version of the overall database, with some dummy data init.

If you go to the "Database" worksheet you will see the cells shaded grey. These are the columns that are to be sorted, then once sorted they are sent to the "output" sheet by pushing the "Send to Output" macro.

Taking a look at the "output" sheet you will see an abbreviated version of the database with a summary box down the bottom. These are all pre coded functions.

What I am down trying to achieve, is getting the names of the columns from the "database sheet" to copy to the "Tags" box next to the output summary so the user knows what type of data he/she is looking at.

The macro in question is in button 89 on the database sheet.


If you need more information I can update.


thanks.


jack

[Bob Phillips]

No attachment!

[Bob Phillips]

Oh I see, you attached it to the first message.

[thejacko5]

yea sorry about that, didnt mean to hide it from you


anyone?

[thejacko5]

theres got to be someone who can figure this one out, I dosnt seem too hard, but I am not at all VBA savvy.

[rory]

When you say "on the condition that the column has been autofiltered", do you mean that the autofilter has been set up on the column, or that there is actually a filter in operation on it - i.e. it's not set to 'All'?
Regards,
Rory

[thejacko5]

that the filter has in fact been activated, so set to a specific variable that is not ALL.


in this case that sort variable would be "X"

[rory]

Try this:

Sub Button89_Click()
Sheets("Output").Range("C501:e513").ClearContents
With Sheets("Database")
myarray2 = Array(3, 3, 3, 3, 3, 3, 3, 3, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 5, 5, 5, 5, 5)
For i = 3 To 25
If FilterOn(.Cells(7, i)) Then
Sheets("Output").Cells(499 + i, myarray2(i - 3)).Value = .Cells(6, i).Value
End If
Next i
End With
End Sub
Function FilterOn(rngcell As Range) As Boolean
On Error GoTo err_handle
With rngcell.Parent.AutoFilter
With .Filters.Item(rngcell.Column - .Range.Column + 1)
FilterOn = .On
End With
End With

clean_up:
Exit Function

err_handle:
FilterOn = False
Resume clean_up
End Function

[thejacko5]

Thank you.

:ipray:

[rory]

Glad to help!

[thejacko5]

Rory,

I have run into a bit of trouble with this macro. In the paste range C501:e513 the data defined in the array by "4" and "5" do not paste into the top cell of the range, only the ones designated by "3" follow the proper range. The others paste several cells down. out of place

Do you know how to fix?


If you dont know what I am talking about, run the macro after sorting the "education" tags and you will see.

[thejacko5]

EDIT: I had intended each type of tag to start copying into the same row in columns c,d,e respectively. (c501,d501,e501)

[rory]

Can you clarify the exact steps required to reproduce the problem?

[thejacko5]

Can you clarify the exact steps required to reproduce the problem?

If you enter the ZIP document and expand the column groupings in the "database" sheet you should see Financial Services, Education, and Information & Media. When you autofilter for "X" on Education and I&M and press the "send to output" button, the column headers will copy to the "Output" worksheet. However, they do not copy to the same row as when the autofilter is performed with Finance headers which copy to the named range "Tags_Area" starting at C60. Instead they copy several rows down. I need them to copy evenly with the top of the "tags" area. You designed most of the original code, but I have modified portions of it to fit my needs.

If there is a way to get all three groups of columns to start copying in the same row that would be the ideal solution.


: pray2:

Thanks.




6517

[rory]

Does this do what you want:
Sub Button86_Click()
'Macro written 8/01 by JRF
'This macro sends the visible cells of the "Database" worksheet to the "Output" worksheet to produce a summary of the desired data.
'*EDIT THIS MACRO* - If you add tags to the database you must alter this macro.
Dim arrGroupCols(1 To 3) As Long, arrOutputCols(1 To 3) As Long, arrOutputRows(1 To 3) As Long
Dim lngStartRow As Long, lngStartCol As Long, lngEndCol As Long, lngGroupMatch As Long
lngStartRow = 60
' First row is FS, second is EDU, third is Information
'If adding/deleting a tag adjust start columns as required
' Start column for groups
arrGroupCols(1) = 3
arrGroupCols(2) = 10
arrGroupCols(3) = 20
' Output columns
arrOutputCols(1) = 3
arrOutputCols(2) = 4
arrOutputCols(3) = 5
' Output rows
arrOutputRows(1) = lngStartRow
arrOutputRows(2) = lngStartRow
arrOutputRows(3) = lngStartRow

Sheets("Output").Range("C4:O300").ClearContents
With Sheets("Database")
.Range("A7:B200,Y7:AB200,AC7:AD200,AG7:AH200,AK7:AL200,AO7:AO200").SpecialCells(xlCellTypeVisible).Copy _
Sheets("Output").Range("C4")
lngStartCol = .Range("Tags").Column
lngEndCol = lngStartCol + .Range("Tags").Columns.Count
End With
'Confirm the "Database" Ranges in the macro above correspond to those in the "Database" Worksheet

Sheets("Output").Range("Tags_Area").ClearContents
With Sheets("Database")
' myarray2 = Array(3, 3, 3, 3, 3, 3, 3, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 5, 5, 5, 5, 5)
For i = lngStartCol To lngEndCol
'Example: If adding a tag adjust the Tags range to include it
If FilterOn(.Cells(7, i)) Then
lngGroupMatch = Application.Match(i, arrGroupCols, 1)
Sheets("Output").Cells(arrOutputRows(lngGroupMatch), arrOutputCols(lngGroupMatch)).Value = .Cells(6, i).Value
arrOutputRows(lngGroupMatch) = arrOutputRows(lngGroupMatch) + 1
End If
Next i
End With
End Sub

[thejacko5]

Does this do what you want:
Sub Button86_Click()
'Macro written 8/01 by JRF
'This macro sends the visible cells of the "Database" worksheet to the "Output" worksheet to produce a summary of the desired data.
'*EDIT THIS MACRO* - If you add tags to the database you must alter this macro.
Dim arrGroupCols(1 To 3) As Long, arrOutputCols(1 To 3) As Long, arrOutputRows(1 To 3) As Long
Dim lngStartRow As Long, lngStartCol As Long, lngEndCol As Long, lngGroupMatch As Long
lngStartRow = 60
' First row is FS, second is EDU, third is Information
'If adding/deleting a tag adjust start columns as required
' Start column for groups
arrGroupCols(1) = 3
arrGroupCols(2) = 10
arrGroupCols(3) = 20
' Output columns
arrOutputCols(1) = 3
arrOutputCols(2) = 4
arrOutputCols(3) = 5
' Output rows
arrOutputRows(1) = lngStartRow
arrOutputRows(2) = lngStartRow
arrOutputRows(3) = lngStartRow

Sheets("Output").Range("C4:O300").ClearContents
With Sheets("Database")
.Range("A7:B200,Y7:AB200,AC7:AD200,AG7:AH200,AK7:AL200,AO7:AO200").SpecialCells(xlCellTypeVisible).Copy _
Sheets("Output").Range("C4")
lngStartCol = .Range("Tags").Column
lngEndCol = lngStartCol + .Range("Tags").Columns.Count
End With
'Confirm the "Database" Ranges in the macro above correspond to those in the "Database" Worksheet

Sheets("Output").Range("Tags_Area").ClearContents
With Sheets("Database")
' myarray2 = Array(3, 3, 3, 3, 3, 3, 3, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 5, 5, 5, 5, 5)
For i = lngStartCol To lngEndCol
'Example: If adding a tag adjust the Tags range to include it
If FilterOn(.Cells(7, i)) Then
lngGroupMatch = Application.Match(i, arrGroupCols, 1)
Sheets("Output").Cells(arrOutputRows(lngGroupMatch), arrOutputCols(lngGroupMatch)).Value = .Cells(6, i).Value
arrOutputRows(lngGroupMatch) = arrOutputRows(lngGroupMatch) + 1
End If
Next i
End With
End Sub


I get 'ambiguous error detected' at FilterOn

[rory]

That would imply that you have two copies of the FilterOn function so you will need to delete one of them.

[thejacko5]

Ok, that ones fixed, now I am getting an "application-defined or object error on

lngStartCol = .Range("Tags").Column
lngEndCol = lngStartCol + .Range("Tags").Columns.Count


I am doing my best to sort this out myself but I just dont know a whole lot about this stuff

[rory]

Sorry - I should have posted the workbook I was working on (it's at home, so I can't now). I added a 'Tags' named range to the data sheet that covers all the column headers that you filter on (from Financial to I&M) so it goes from C6 to X6 from recollection.

[thejacko5]

ok, I can handle that, if I add that names range should I be in better shape?


GOT that.

Now im receiving another app error at

Sheets("Output").Cells(arrOutputRows(lngGroupMatch), arrOutputCols(lngGroupMatch)).Value = .Cells(6, i).Value

If you can point out what is needed i might be able to sort it out

[rory]

I can't see anything wrong with that (It worked in my testing last night) assuming you have valid values in the lngGroupMatch and i variables. Can you post the current version of the workbook?