First row of filtered range not selecting

[Legacy 177844]

Hi, I'm a newbie here but have (almost) got the code to work the way I want save one problem which I'm hoping someone can give me a solution to?

Situation:
8 columns of data with filters
When a filter is selected, the first visible row is identified and each cell value in that row is sent to sheet2 into various pre-determined cell locations (sheet 2 being a summary sheet).
The code does the job except when I select filters to display the first row of data that would be visible if no filters were active.

Code:

Sub tester()
' ' On the active sheet (sheet1) with the autofiler applied,
' ' select the first visible cell of the first row and copy
' ' that value to cell A1 in sheet2.

    ActiveSheet.UsedRange.SpecialCells(xlCellTypeVisible).Areas(2).Cells(1).Select
    Selection.Copy Worksheets("Sheet2").Range("A1")
    
' ' Return to the active sheet (sheet1) with autofiler applied and
' ' select the second visible cell of the first row and copy
' ' it to cell A2 in sheet2.
    
    Sheets("Sheet1").Select
    ActiveSheet.UsedRange.SpecialCells(xlCellTypeVisible).Areas(2).Cells(2).Select
    Selection.Copy Worksheets("Sheet2").Range("A2")

    Sheets("Sheet1").Select
    ActiveSheet.UsedRange.SpecialCells(xlCellTypeVisible).Areas(2).Cells(3).Select
    Selection.Copy Worksheets("Sheet2").Range("A7")
    
    Sheets("Sheet1").Select
    ActiveSheet.UsedRange.SpecialCells(xlCellTypeVisible).Areas(2).Cells(4).Select
    Selection.Copy Worksheets("Sheet2").Range("A8")
    
    Sheets("Sheet1").Select
    ActiveSheet.UsedRange.SpecialCells(xlCellTypeVisible).Areas(2).Cells(5).Select
    Selection.Copy Worksheets("Sheet2").Range("C4")

    Sheets("Sheet1").Select
    ActiveSheet.UsedRange.SpecialCells(xlCellTypeVisible).Areas(2).Cells(6).Select
    Selection.Copy Worksheets("Sheet2").Range("D2")
    
    Sheets("Sheet1").Select
    ActiveSheet.UsedRange.SpecialCells(xlCellTypeVisible).Areas(2).Cells(7).Select
    Selection.Copy Worksheets("Sheet2").Range("C6")
    
    
' ' Once all the above is complete, return to
' '  the sheet with the autofilter applied and reset
' '  the filters

    Sheets("Sheet1").Select
    ActiveSheet.ShowAllData
    
' ' Finally, go to sheet 2 where all the new data has been populated

    Sheets("Sheet2").Select
    
End Sub

 

[taigovinda]

Welcome to the board!

You have the word "Areas" - I think that is the issue because it looks for a second contiguous area and if nothing is filtered out then there will only be one area... try one of the below two - the first if you want to copy everything (formulas, formats) and the second if you want to copy only values (and preserve formulas, formats that exist in Sheet2).

Note that "select" is not used, nor is "activesheet" - these should be avoided as they slow things down and create potential problems by relying on something or other to be selected/active which may unexpectedly not be the case... Also added error handling in case there is no filter or no filter applied. Hopefully these elements are instructive for you.

Formulas, formats (i.e., copy all)

Sub ValuesAndFormatsAndFormulas()
Dim i As Long

With Sheets("Sheet1")

    'find the first row *below* the header row
    On Error GoTo norange 'if there's an error, it's because there is no autofilter; exit sub and give msg
        i = .AutoFilter.Range.Row + 1
        While .Rows(i).Hidden = True
            i = i + 1
        Wend
    On Error GoTo 0
    
    'copy each individually - takes longer...  no need to select anything though
    .Cells(i, 1).Copy Destination:=Worksheets("Sheet2").Range("A1")
    .Cells(i, 2).Copy Destination:=Worksheets("Sheet2").Range("A2")
    .Cells(i, 3).Copy Destination:=Worksheets("Sheet2").Range("A7")
    .Cells(i, 4).Copy Destination:=Worksheets("Sheet2").Range("A8")
    .Cells(i, 5).Copy Destination:=Worksheets("Sheet2").Range("C4")
    .Cells(i, 6).Copy Destination:=Worksheets("Sheet2").Range("D2")
    .Cells(i, 7).Copy Destination:=Worksheets("Sheet2").Range("C6")

    'show all data on "Sheet1"
    On Error Resume Next 'in case no filters are applied, ignore the error this would return
    .ShowAllData
    On Error GoTo 0
    
End With

Sheets("Sheet2").Activate

Exit Sub
norange:
MsgBox "There is no autofilter set up (let alone used) on 'Sheet1' - please try again.", vbCritical, "Aborted!!!"

End Sub

Values only (assigns values thru code rather than using 'copy special' ...I'm sure there is a way to assign all 7 values at one stroke instead of using 7 different lines of code - maybe someone else will step in with that line of code ):

Sub ValuesOnly()
Dim i As Long

With Sheets("Sheet1")

    'find the first row *below* the header row
    On Error GoTo norange 'if there's an error, it's because there is no autofilter; exit sub and give msg
        i = .AutoFilter.Range.Row + 1
        While .Rows(i).Hidden = True
            i = i + 1
        Wend
    On Error GoTo 0
    
    'copy only the values and not the formatting - faster
    Worksheets("Sheet2").Range("A1").Value = .Cells(i, 1).Value
    Worksheets("Sheet2").Range("A2").Value = .Cells(i, 2).Value
    Worksheets("Sheet2").Range("A7").Value = .Cells(i, 3).Value
    Worksheets("Sheet2").Range("A8").Value = .Cells(i, 4).Value
    Worksheets("Sheet2").Range("C4").Value = .Cells(i, 5).Value
    Worksheets("Sheet2").Range("D2").Value = .Cells(i, 6).Value
    Worksheets("Sheet2").Range("C6").Value = .Cells(i, 7).Value

    'show all data on "Sheet1"
    On Error Resume Next 'in case no filters are applied, ignore the error this would return
    .ShowAllData
    On Error GoTo 0
    
End With

Sheets("Sheet2").Activate

Exit Sub
norange:
MsgBox "There is no autofilter set up (let alone used) on 'Sheet1' - please try again.", vbCritical, "Aborted!!!"

End Sub

Hope that helps!

Tai

 

[taigovinda]

As an afterthought... you should always avoid loops when possible; in each version of the macro above, a better way to find the first visible row instead of looping 'i+1' could've been this:

    'find the first row *below* the header row
    On Error GoTo norange 'if there's an error, it's because there is no autofilter; exit sub and give msg
        i = .AutoFilter.Range.Offset(1).SpecialCells(xlCellTypeVisible).Cells(1).Row
    On Error GoTo 0

Because it looks at an offset of the autofilter range (the same range, but one cell lower), it has the potential to error in the unlikely event that column is filled all the way to the bottom (e.g., headers in row 1 and cells filled all the way to 65536 (in 2003 version), it will try to look at 2:65537 which doesn't exist and will cause an error).

 

[AlphaFrog]

Sub tester()
' ' On the active sheet (sheet1) with the autofiler applied,
' ' select the first visible cell of the first row and copy
' ' that value to cell A1 in sheet2.

With Sheets("Sheet1")

    .UsedRange.Offset(1).SpecialCells(xlCellTypeVisible).Cells(1).Copy _
        Worksheets("Sheet2").Range("A1")
    
' ' Return to the active sheet (sheet1) with autofiler applied and
' ' select the second visible cell of the first row and copy
' ' it to cell A2 in sheet2.
    
    .UsedRange.Offset(1).SpecialCells(xlCellTypeVisible).Cells(2).Copy _
        Worksheets("Sheet2").Range("A2")

    .UsedRange.Offset(1).SpecialCells(xlCellTypeVisible).Cells(3).Copy _
        Worksheets("Sheet2").Range("A7")
    
    .UsedRange.Offset(1).SpecialCells(xlCellTypeVisible).Cells(4).Copy _
        Worksheets("Sheet2").Range("A8")
    
    .UsedRange.Offset(1).SpecialCells(xlCellTypeVisible).Cells(5).Copy _
        Worksheets("Sheet2").Range("C4")

    .UsedRange.Offset(1).SpecialCells(xlCellTypeVisible).Cells(6).Copy _
        Worksheets("Sheet2").Range("D2")
    
    .UsedRange.Offset(1).SpecialCells(xlCellTypeVisible).Cells(7).Copy _
        Worksheets("Sheet2").Range("C6")
    
    
' ' Once all the above is complete, return to
' '  the sheet with the autofilter applied and reset
' '  the filters

    .ShowAllData
    
End With
    
' ' Finally, go to sheet 2 where all the new data has been populated

    Sheets("Sheet2").Select
    
End Sub

 

[Legacy 177844]

Thanks, taigovinda!

The code and explanation are much appreciated

I do have one other question - if you don't have the time that's totally understandable (you've already been a big help) -

Once cell data has been transferred to sheet2, if I then change/update that data in sheet2 how do I code so those changes then update sheet1?

(suggestions/pointers would also do!)

thinking aloud(!)
(....if cell value is changed in sheet2, update the original cell which the data was initially transferred from...)

 

[Legacy 177844]

Thank you also, AlphaFrog - so pleased to receive the support!

 

[taigovinda]

How would you know which cell the data came from? Since you re-set the filter when you originally transferred values, I'm not sure how to tell which row needs to be updated...

I guess if this is something you're going to want to do, you could add to the first procedure, one more cell to write to. Put the value of 'i' in that last cell, then you'll know which row needs to be updated if you want to update the data based on changes made to Sheet2. So once you've made that change to the first sub (from post 2), basically if you put the value of 'i' in, say, Z1 sheet2, the 2nd procedure would be something like (untested)...

sub WriteBack()
dim i as long
with sheets("Sheet2")
  i=.range("Z1")
  
  sheets("Sheet1").cells(i,1) = .range("A1").value
  sheets("Sheet1").cells(i,2) = .range("A2").value
''''''copy over the other values in here with 4 more lines of code'''
'''......'''
  sheets("Sheet1").cells(i,7) = .range("C6").value
end with

msgbox "Values written to 'Sheet1' in row " & i & ".",vbinformation,"Values Transferred"
end sub

edit: or maybe with the first procedure, put the value of i in an unused cell in Sheet1 (instead of Sheet2) if you wanted, then you'd have to change the above to read i from there...

 

[AlphaFrog]

Once cell data has been transferred to sheet2, if I then change/update that data in sheet2 how do I code so those changes then update sheet1?

If in the Tester macro you log on Sheet2 the row number that is copied, then it would be simple to have a 2nd macro just copy the values back to Sheet1 using that row number.

in Tester, record the copied row number to sheet2 cell D3 for example.

Worksheets("Sheet2").Range("D3").Value = .UsedRange.Offset(1).SpecialCells(xlCellTypeVisible).Cells(1).Row

In new 2nd macro, copy cell Sheet2A2 to Sheet1 A&row number

r = Worksheets("Sheet2").Range("D3").Value
Sheets("Sheet1").Range("A" & r).Value = Sheets("Sheet2").Range("A2").Value

 

[Legacy 177844]

Fantastic!

A weight has been lifted! I am not worthy, oh vba gods