Go Premium for a chance to win a PS4. Enter to Win

x
  • Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 297
  • Last Modified:

Excel VBA to copy row where 2 cells meet criteria

I have 2 workbooks.
One is named "total parts" (has 1 sheet named Total Parts)
The other "PLGFP" (Has 3 sheets Sheet 1 ...)

I want to copy 2 types of data from the 'total parts' sheet which usually has a few thousand rows.

I need to look for any row in 'total parts' that has "OGM" in Col J and "YTD" in Col O and copy that row into Sheet 1 of PLGFP
Then
I need to look for any row in 'total parts' that has "TS CRU" in Col J and "YTD" in Col O and copy that row into Sheet 2 of PLGFP.

So I expect to have a few hundred rows in each Sheet 1 & 2  of book PLGFP,  which I will save and then perform some calculations
This will be a monthly automated macro and the number of rows will vary.

0
Mswetsky
Asked:
Mswetsky
  • 2
1 Solution
 
grogmanCommented:
Not exactly the prettiest macro I have ever written, but perhaps this will get you started. The code assumes that the macro is stored in the "PLGFP" file. The macro searches the currently open workbooks to find the "Total Parts" workbook, and if it is not already open, opens it for you. It then loops through the data copying and pasting to the appropriate sheets in the "PLGFP" file. The code is kind of slow (a result of actually selecting workbooks  and using the copy and paste methods). The code could be made faster by directly referencing the sheets and ranges and writing each cell's data, but the code would be much longer. Sample:

Sub Test()
    Dim PartsWB As Workbook
    Dim DestWB As Workbook
    Dim ArrWB As Workbook
    Dim ceLL As Range
    Dim boolWB As Boolean
    Dim partsRange As Range
    Dim partSheet As Worksheet
   
    boolWB = False
    Set DestWB = ThisWorkbook
    For Each ArrWB In Application.Workbooks
        If ArrWB.Name = "Total Parts.xlsx" Then
            Set PartsWB = ArrWB
            boolWB = True
        End If
    Next
    If boolWB = False Then
        Set PartsWB = Application.Workbooks.Open("Total Parts.xlsx")
    End If
    Set partSheet = PartsWB.Sheets("total parts")
    Set partsRange = partSheet.Range("J1:" & Range("J1").End(xlDown).Address)
    Application.ScreenUpdating = False
    For Each ceLL In partsRange
        PartsWB.Activate
        If ceLL.Value = "OGM" And ceLL.Offset(0, 5).Value = "YTD" Then
            ceLL.EntireRow.Copy
            DestWB.Activate
            DestWB.Sheets("Sheet1").Select
            Range("A1048576").End(xlUp).Offset(1, 0).Select
            ActiveCell.PasteSpecial xlPasteAllUsingSourceTheme
        End If
        If ceLL.Value = "TS CRU" And ceLL.Offset(0, 5).Value = "YTD" Then
            ceLL.EntireRow.Copy
            DestWB.Activate
            DestWB.Sheets("Sheet2").Select
            Range("A1048576").End(xlUp).Offset(1, 0).Select
            ActiveCell.PasteSpecial xlPasteAllUsingSourceTheme
        End If
    Next ceLL
    Application.ScreenUpdating = True
End Sub
0
 
MswetskyAuthor Commented:
Wow this looks good. I will have this acting at the point when there is focus on the Total Parts book and the PL is open so this may be great to get me going.
0
 
MswetskyAuthor Commented:
As I mentioned I was at a point in a large macro that I was able to include the needed part of your macro with some amendments. Thank you very much for the prompt reply.
0

Featured Post

[Webinar] Cloud and Mobile-First Strategy

Maybe you’ve fully adopted the cloud since the beginning. Or maybe you started with on-prem resources but are pursuing a “cloud and mobile first” strategy. Getting to that end state has its challenges. Discover how to build out a 100% cloud and mobile IT strategy in this webinar.

  • 2
Tackle projects and never again get stuck behind a technical roadblock.
Join Now