Improve company productivity with a Business Account.Sign Up

x
  • Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 302
  • 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
Mitch Swetsky
Asked:
Mitch Swetsky
  • 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
 
Mitch SwetskyBusiness AnalystAuthor 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
 
Mitch SwetskyBusiness AnalystAuthor 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
Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.

Join & Write a Comment

Featured Post

Free Tool: SSL Checker

Scans your site and returns information about your SSL implementation and certificate. Helpful for debugging and validating your SSL configuration.

One of a set of tools we are providing to everyone as a way of saying thank you for being a part of the community.

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