Public Function getItemLocation(sLookFor As String, _ rngSearch As Range, _ Optional bFullString As Boolean = True, _ Optional bLastOccurance As Boolean = True, _ Optional bFindRow As Boolean = True) As Long Dim Cell As Range Dim iLookAt As Integer Dim iSearchDir As Integer Dim iSearchOdr As Integer If (bFullString) _ Then iLookAt = xlWhole Else iLookAt = xlPart End If If (bLastOccurance) _ Then iSearchDir = xlPrevious Else iSearchDir = xlNext End If If Not (bFindRow) _ Then iSearchOdr = xlByColumns Else iSearchOdr = xlByRows End If With rngSearch If (bLastOccurance) _ Then Set Cell = .Find(sLookFor, .Cells(1, 1), xlValues, iLookAt, iSearchOdr, iSearchDir) Else Set Cell = .Find(sLookFor, .Cells(.Rows.Count, .Columns.Count), xlValues, iLookAt, iSearchOdr, iSearchDir) End If End With If Cell Is Nothing Then getItemLocation = 0 ElseIf Not (bFindRow) _ Then getItemLocation = Cell.Column Else getItemLocation = Cell.Row End If Set Cell = Nothing End Function
Sub Macro6() ' ' Macro6 Macro ' R6 ' ' ActiveSheet.Range("$A$1:$Q$353").AutoFilter Field:=17, Criteria1:="1" Rows("1:1").Select Range("C1").Activate Selection.EntireRow.Hidden = True Cells.Select Range("C1").Activate Selection.Copy Sheets("SHO").Select ActiveSheet.Paste Sheets("Data").Select Application.CutCopyMode = False ActiveSheet.ShowAllData Rows("288:288").Select Range("C288").Activate ActiveWindow.SmallScroll Down:=-15 ActiveWindow.ScrollRow = 281 ActiveWindow.ScrollRow = 94 ActiveWindow.ScrollRow = 1 Rows("2:2").Select Range("C2").Activate Selection.EntireRow.Hidden = False Rows("1:1").Select Range("C1").Activate Selection.EntireRow.Hidden = False End Sub
Sub doCopyFilteredData() Dim sSrcSht As String Dim lLastRow As Long Dim lLastCol As Long sSrcSht = "Sheet1" With Sheets(sSrcSht) 'remove any existing filters Application.ScreenUpdating = False .AutoFilterMode = False 'FIND LAST USED COLUMN lLastCol = getItemLocation("*", .Cells, bFindRow:=False) 'APPLY FILTER .Cells.AutoFilter Field:=17, Criteria1:="1" 'FIND LAST VISIBLE ROW lLastRow = getItemLocation("*", .Cells) If lLastRow > 0 _ Then 'FREE MEMORY OF ANY COPIED INFORMATION Application.CutCopyMode = False 'CLEAR PREVIOUS DATA Sheets("SHO").Cells.Clear 'COPY FILTERED DATA .Range(.Cells(1, 1), .Cells(lLastRow, lLastCol)).Copy 'PASTE FILTERED DATA Sheets("SHO").Cells(1, 1).PasteSpecial 'REMOVE ANY FILTER Application.CutCopyMode = False End If .AutoFilterMode = False Application.ScreenUpdating = True End With End Sub Public Function getItemLocation(sLookFor As String, _ rngSearch As Range, _ Optional bFullString As Boolean = True, _ Optional bLastOccurance As Boolean = True, _ Optional bFindRow As Boolean = True) As Long Dim Cell As Range Dim iLookAt As Integer Dim iSearchDir As Integer Dim iSearchOdr As Integer If (bFullString) _ Then iLookAt = xlWhole Else iLookAt = xlPart End If If (bLastOccurance) _ Then iSearchDir = xlPrevious Else iSearchDir = xlNext End If If Not (bFindRow) _ Then iSearchOdr = xlByColumns Else iSearchOdr = xlByRows End If With rngSearch If (bLastOccurance) _ Then Set Cell = .Find(sLookFor, .Cells(1, 1), xlValues, iLookAt, iSearchOdr, iSearchDir) Else Set Cell = .Find(sLookFor, .Cells(.Rows.Count, .Columns.Count), xlValues, iLookAt, iSearchOdr, iSearchDir) End If End With If Cell Is Nothing Then getItemLocation = 0 ElseIf Not (bFindRow) _ Then getItemLocation = Cell.Column Else getItemLocation = Cell.Row End If Set Cell = Nothing End Function