Previous Topic Next Topic

Needed a VBA.

Solved/Closed
doss - Jun 1, 2011 at 02:36 PM
rizvisa1 Posts 4479 Registration date Thursday January 28, 2010 Status Contributor Last seen May 5, 2022 - Jun 13, 2011 at 10:52 AM
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
rizvisa1 Posts 4479 Registration date Thursday January 28, 2010 Status Contributor Last seen May 5, 2022 767
Jun 1, 2011 at 02:57 PM
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
0
Answer 2 / 3
doss
Jun 1, 2011 at 04:15 PM
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
0
rizvisa1 Posts 4479 Registration date Thursday January 28, 2010 Status Contributor Last seen May 5, 2022 767
Jun 1, 2011 at 06:02 PM
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
0
Answer 3 / 3
doss
Jun 2, 2011 at 04:36 AM
Thank u rizvisa1
It works... thank u...
0
doss
Jun 13, 2011 at 08:29 AM
Thanks alot... this was usefull..
0
rizvisa1 Posts 4479 Registration date Thursday January 28, 2010 Status Contributor Last seen May 5, 2022 767
Jun 13, 2011 at 10:52 AM
you are welcome
0