Copy or not copy depends on cell value

[KlausW]

Hi

I am using this VBA code to copy from one range to another. It works just fine. Can anyone help so it only copying if the number in column P is less than 58000.

Example:
In cell P2 stand 58000, so K2 should not be copied. In cell P10 stand 57000 is written, so K10 must be copied.

Any help will be appreciated

Best regards

Klaus W

Sub Macro3()

    Sheets("Worksheet").Range("k2:k400").Copy _
    Destination:=Sheets("Worksheet").Range("b2")
    Application.CutCopyMode = False
    Sheets("Worksheet").Range("b2:b400").RemoveDuplicates _
    Columns:=1, Header:=xlNo
    
   End Sub

 

[Joe4]

Try this:

Sub Macro3()

    Dim ws As Worksheet
    Dim rng As Range
    Dim cell As Range
    
    Set ws = Sheets("Worksheet")
    Set rng = ws.Range("k2:k400")
    
    Application.ScreenUpdating = False
    
    For Each cell In rng
        If cell <> "" And cell.Value < 58000 Then
            ws.Cells(ws.Rows.Count, "B").End(xlUp).Offset(1, 0).Value = cell.Value
        End If
    Next cell
    
    ws.Range("b2:b400").RemoveDuplicates Columns:=1, Header:=xlNo
    
    Application.ScreenUpdating = True
    
End Sub

 

[KlausW]

Try this:

Sub Macro3()

    Dim ws As Worksheet
    Dim rng As Range
    Dim cell As Range
   
    Set ws = Sheets("Worksheet")
    Set rng = ws.Range("k2:k400")
   
    Application.ScreenUpdating = False
   
    For Each cell In rng
        If cell <> "" And cell.Value < 58000 Then
            ws.Cells(ws.Rows.Count, "B").End(xlUp).Offset(1, 0).Value = cell.Value
        End If
    Next cell
   
    ws.Range("b2:b400").RemoveDuplicates Columns:=1, Header:=xlNo
   
    Application.ScreenUpdating = True
   
End Sub

It doesn't work, vba code should only copy the cells if the number in column P is less than 58000. KW

 

[Peter_SSs]

Try this instead.

Sub Test()
  With Sheets("Worksheet")
    With .Range("K1:P400")
      .AutoFilter Field:=6, Criteria1:="<58000"
      If .Columns(1).SpecialCells(xlVisible).Count > 1 Then .Offset(1).Resize(.Rows.Count - 1, 1).Copy Destination:=.Parent.Range("B2")
    End With
    .AutoFilterMode = False
    .Range("B2:B400").RemoveDuplicates Columns:=1, Header:=xlNo
  End With
End Sub

 

[KlausW]

Try this instead.

Sub Test()
  With Sheets("Worksheet")
    With .Range("K1:P400")
      .AutoFilter Field:=6, Criteria1:="<58000"
      If .Columns(1).SpecialCells(xlVisible).Count > 1 Then .Offset(1).Resize(.Rows.Count - 1, 1).Copy Destination:=.Parent.Range("B2")
    End With
    .AutoFilterMode = False
    .Range("B2:B400").RemoveDuplicates Columns:=1, Header:=xlNo
  End With
End Sub

Hi Peter_SSs it's just as it should be, thank you very much. Have a nice day, regards from Denmark Klaus W

 

[Joe4]

It doesn't work, vba code should only copy the cells if the number in column P is less than 58000. KW

Sorry, I misread and thought the value of 58000 was in column K.

 

[Peter_SSs]

Hi Peter_SSs it's just as it should be, thank you very much. Have a nice day, regards from Denmark Klaus W

You are welcome. Thanks for the follow-up.