Previous Topic Next Topic

Needed a VBA.

Solved/Closed
Report
-
Posts
4476
Registration date
Thursday January 28, 2010
Status
Contributor
Last seen
August 2, 2020
 -
Hello,

I'm very new to progamming kind of stuff... i need to generate a report from a excel sheet.
Coloumn Q of "data" sheet has only 0 or 1, which is output of some formula calculation.
I need all 1 to be copied to "SHO" sheet. based on the copied content i need to impletement some formula. value 1 will not be same always. if today q coulmn is 1 for a row, tomorrow it may be 0... Max 600 rows need to be supported. Kindly help..

3 replies

Answer 1 / 3
Posts
4476
Registration date
Thursday January 28, 2010
Status
Contributor
Last seen
August 2, 2020
 768
1. Goto Tool and start macro recorder
2. Apply filters on column Q for the value u want to copy for
3. Copy all the visible rows
4. paste on the other sheet SHO
5. Stop the macro

This will give you a generic template. Things to modify would be
1. What is the last row to be copied
2. If rows are to be appended to that SHO sheet, then from what row you should paste. For both you can use the function below

Sample Call
lMaxRows = getItemLocation("*", Sheets("SHO").Cells)
Note if sheet is blank then it will return 0 


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
Answer 2 / 3

Thank u rizvisa1
Thanks alot for your response..
I would be more thank full if u can explain how to use the macro i recorded.
macro code is 

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




as i'm new bee in this stuff.. kindly help me out..wat need to be edited
Report
Posts
4476
Registration date
Thursday January 28, 2010
Status
Contributor
Last seen
August 2, 2020
 768
try this 
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
Answer 3 / 3

Thank u rizvisa1
It works... thank u...
Report

Thanks alot... this was usefull..
Report
Posts
4476
Registration date
Thursday January 28, 2010
Status
Contributor
Last seen
August 2, 2020
 768
you are welcome
Ask a question