VBA - Copying cells in a range that match criteria

[NathanA]

Hello everybody,

I am trying to write VBA code to copy cells from a range of non-contiguous columns (A:K, O:Q) to a new sheet if certain criteria is met (a cell in columns O:Q is populated and cells in column F do not contain a key word). I am able to specify the criteria but the code I've written to select the range of columns ('Select columns to copy) brings over all the original data. I'm unsure of how to still select the range "A:K,O:Q" and select the cell values that match the criteria.

Sub CopyValues()


Set i = Sheets("Sheet1")
Set e = Sheets("Sheet2")
Dim d
Dim j
d = 1
j = 2


'Choose length of data to copy
Do Until IsEmpty(i.Range("A" & j))
    'Specify criteria
    If (i.Range("O" & j) <> "" Or i.Range("P" & j) <> "" Or i.Range("Q" & j) <> "") And _
    i.Range("F" & j) <> "HR" Then
    d = d + 1
    'Select columns to copy
    i.Range("A:K,O:Q").Copy e.Range("A1")


End If
j = j + 1
Loop


End Sub

Any guidance would be much appreciated.

 

[mumps]

Try:

Sub CopyValues()
    Application.ScreenUpdating = False
    Dim rng As Range, bottomA As Long, srcWS As Worksheet, desWS As Worksheet
    Set srcWS = Sheets("Sheet1")
    Set desWS = Sheets("Sheet2")
    With srcWS
        bottomA = .Range("A" & .Rows.Count).End(xlUp).Row
        For Each rng In .Range("A2:A" & bottomA)
            If WorksheetFunction.CountA(.Range("O" & rng.Row & ":Q" & rng.Row)) > 0 And .Range("F" & rng.Row) <> "HR" Then
                Intersect(.Rows(rng.Row), .Range("A:K")).Copy desWS.Cells(desWS.Rows.Count, "A").End(xlUp).Offset(1, 0)
                Intersect(.Rows(rng.Row), .Range("O:Q")).Copy desWS.Cells(desWS.Rows.Count, "O").End(xlUp).Offset(1, 0)
            End If
        Next rng
    End With
    Application.ScreenUpdating = True
End Sub

 

[mumps]

Please try this version instead of the one in my previous post:

Sub CopyValues()
    Application.ScreenUpdating = False
    Dim rng As Range, bottomA As Long, srcWS As Worksheet, desWS As Worksheet, x As Long: x = 2
    Set srcWS = Sheets("Sheet1")
    Set desWS = Sheets("Sheet2")
    With srcWS
        bottomA = .Range("A" & .Rows.Count).End(xlUp).Row
        For Each rng In .Range("A2:A" & bottomA)
            If WorksheetFunction.CountA(.Range("O" & rng.Row & ":Q" & rng.Row)) > 0 And .Range("F" & rng.Row) <> "HR" Then
                Intersect(.Rows(rng.Row), .Range("A:K")).Copy desWS.Cells(desWS.Rows.Count, "A").End(xlUp).Offset(1, 0)
                Intersect(.Rows(rng.Row), .Range("O:Q")).Copy desWS.Cells(x, "O")
                x = x + 1
            End If
        Next rng
    End With
    Application.ScreenUpdating = True
End Sub

 

[NathanA]

Hi,

Thanks for looking into this!

The code brings across all rows where cells in F do not equal "HR" and does not differentiate that a cell in O:Q needs to be greater than 0. Is it possible to only bring across the range of columns where the number in one of the cells in O:Q is greater than 0 (and the keyword is still met)?

 

[mumps]

Replace "CountA" with "Sum" in the code.

 

[NathanA]

Thanks, I've made that update and I've changed .Copy desWS.Cells(x, "O") to .Copy desWS.Cells(x, "L") to remove the gap when pasting the cells into "Sheet2".

I'm trying to paste the cell values only however the code is also pasting formulas. Is it possible to add in a PasteSpecial condition to paste only the values?

 

[mumps]

This should take care of pasting only the values and eliminating the gap.

Sub CopyValues()
    Application.ScreenUpdating = False
    Dim rng As Range, bottomA As Long, srcWS As Worksheet, desWS As Worksheet
    Set srcWS = Sheets("Sheet1")
    Set desWS = Sheets("Sheet2")
    With srcWS
        bottomA = .Range("A" & .Rows.Count).End(xlUp).Row
        For Each rng In .Range("A2:A" & bottomA)
            If WorksheetFunction.Sum(.Range("O" & rng.Row & ":Q" & rng.Row)) > 0 And .Range("F" & rng.Row) <> "HR" Then
                Intersect(.Rows(rng.Row), .Range("A:K,O:Q")).Copy
                desWS.Cells(desWS.Rows.Count, "A").End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
            End If
        Next rng
    End With
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub

 

[NathanA]

Thanks, I really appreciate your help and the code works perfectly. I added

 desWS.Rows("2:" & Rows.Count).ClearContents

after setting the destination worksheet so that when I rerun the code it replaces the old data rather than adding the data again to the bottom.

 

[mumps]

You are very welcome.