Can this be done? If Yes, How?

[Closed]
Report
Posts
3
Registration date
Tuesday January 15, 2013
Status
Member
Last seen
February 8, 2013
-
Posts
3
Registration date
Tuesday January 15, 2013
Status
Member
Last seen
February 8, 2013
-
Hello,

This is my beginners attempt to write VBA code (I just wrote a macro to write MsgBox "Hello World" :-))
Please chk the Following excel file

http://speedy.sh/aEesR/SampleSheet.xlsx

There are two sheets
Sheet1
Sheet2
I want to copy all the rows of Sheet1 in which
1)the D column has a value"Yes"
AND
2)G column also has the value "Yes"

Copy the entire rows which fulfill above criteria AND
1) Paste those at the bottom of the grey area of Sheet2
2)Also insert a number of those many blank rows below the grey area so that it doesnt overwrite the yellow area.

P.S.: Please do not hardcode the range of rows and columns as the actual data may be different

2 replies

Posts
4476
Registration date
Thursday January 28, 2010
Status
Contributor
Last seen
August 2, 2020
768
Do this
1. Start macro recorder
2. Go to sheet 1 and apply filters and filter data on "Yes" in column D and "Yes" in column G
3. Select all visible range
4 goto sheet 2 and paste
stop marco recoder

paste the code back here generated by macro recorder
Posts
3
Registration date
Tuesday January 15, 2013
Status
Member
Last seen
February 8, 2013

Heres the code that was generated.But i cannot understand a thing :-(

Sub RecordedMacro()
'
' RecordedMacro Macro
'

'
Selection.AutoFilter
ActiveSheet.Range("$D$2:$G$12").AutoFilter Field:=1, Criteria1:="Yes"
ActiveSheet.Range("$D$2:$G$12").AutoFilter Field:=4, Criteria1:="Yes"
Range("B5:G12").Select
Selection.Copy
Sheets("Sheet2").Select
Range("A9").Select
Application.CutCopyMode = False
Sheets("Sheet1").Select
Selection.Copy
Sheets("Sheet2").Select
ActiveSheet.Paste
Rows("13:13").Select
Application.CutCopyMode = False
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Rows("13:13").Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
End Sub
Posts
4476
Registration date
Thursday January 28, 2010
Status
Contributor
Last seen
August 2, 2020
768
This is what your recorded macro did

Sub RecordedMacro2()
'
' RecordedMacro Macro
'

'
   Selection.AutoFilter ' what ever you selected in that area it is aplying filter
   ActiveSheet.Range("$D$2:$G$12").AutoFilter Field:=1, Criteria1:="Yes" 'apply filter on 1 column in range D:G
   ActiveSheet.Range("$D$2:$G$12").AutoFilter Field:=4, Criteria1:="Yes" 'apply filter on 4 column in range D:G
   
   Range("B5:G12").Select
   Selection.Copy 'copy the visible cells in range selected
   
   Sheets("Sheet2").Select
   Range("A9").Select
   
   Application.CutCopyMode = False ' clean out any thing that was copied (so you lost what you copied before at this point)
   Sheets("Sheet1").Select
   Selection.Copy 'copy the selected area in sheet 1
   
   Sheets("Sheet2").Select
   ActiveSheet.Paste ' paste what ever was copied
   
   Rows("13:13").Select 'select row 13
   Application.CutCopyMode = False
   Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove 'inserting cells in selection (since row is selected, a row will get inserted. the format of the row will come from above
   Rows("13:13").Select
   Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
   Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
   Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
End Sub
Posts
4476
Registration date
Thursday January 28, 2010
Status
Contributor
Last seen
August 2, 2020
768
Try this
Column D and G are hard code for filter. Column G is assumed to be last column to be copied. Read the code to understand and modify as you see fit

Sub RecordedMacro()

   Dim lastGrayRow      As Long
   Dim copyToSheet      As String
   Dim copyFromSheet    As String
   Dim filterRows       As Long
   Dim lastRow          As Long
   
   copyToSheet = "Sheet2"
   copyFromSheet = "Sheet1"
   
   lastGrayRow = findLastColorRow(copyToSheet) 'find which last row has the required color
   
   If (lastGrayRow = 0) Then Exit Sub ' cannot find the row, exit
   
   Sheets(copyFromSheet).AutoFilterMode = False  ' remove any filter if present
   
   With Sheets(copyFromSheet)
      With .Range("D2:G" & .Cells.Rows.Count)
         .AutoFilter Field:=1, Criteria1:="Yes"
         .AutoFilter Field:=4, Criteria1:="Yes"
      End With
      
      filterRows = Application.WorksheetFunction.Subtotal(3, .Range("G2:G" & .Cells.Rows.Count)) - 1
      If (filterRows < 1) Then Exit Sub
      lastRow = .Range("G" & .Cells.Rows.Count).End(xlUp).Row
      
      Application.CutCopyMode = False
      Sheets(copyToSheet).Rows(lastGrayRow + 1 & ":" & lastGrayRow + filterRows).Insert Shift:=xlShiftDown, CopyOrigin:=xlFormatFromRightOrBelow
      .Range("B3:G" & lastRow).Copy
      Sheets(copyToSheet).Cells(lastGrayRow + 1, "A").PasteSpecial
      Application.CutCopyMode = False
      
    End With
  
End Sub

Public Function findLastColorRow(copyToSheet As String)
   
    Application.FindFormat.Clear
    With Application.FindFormat.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorDark1
        .TintAndShade = -0.249977111117893 ' this is the gray color (as per macro on Office 2007)
        .PatternTintAndShade = 0
    End With
    Application.FindFormat.Locked = True
    
    With Sheets(copyToSheet).Cells
      Set Cell = .Find(What:="", _
                        After:=.Cells(1, 1), _
                        LookIn:=xlValues, _
                        LookAt:=xlPart, _
                        SearchDirection:=xlPrevious, _
                        SearchOrder:=xlByRows, _
                        SearchFormat:=True)
      If (Cell Is Nothing) Then
         findLastColorRow = 0
      Else
         findLastColorRow = Cell.Row
      End If
      Set Cell = Nothing
      
   End With
    
End Function
Posts
3
Registration date
Tuesday January 15, 2013
Status
Member
Last seen
February 8, 2013

thanks for your time rizvisa1. Dint try this out yet. Will do it this weekend and let you know the results.