VBA - Excel Copy and paste range with criteria

Question

I want to copy a range in Sheet1 range A1:A100 where in the each cells filled with value like "Animal", "Plant", "Rock", and "Sand". Then, I want paste in Sheet2 range B1:B100 with conditions if the value at Range A1:A100 is "Animal" paste with "1", if the value is "Plant" paste with "2", ect.

How I write the VBA code? With simple and reducing memory usage. My code :

Sub copyrange()
    Dim i           As Long
    Dim lRw         As Long
    Dim lRw_2       As Long


    Application.ScreenUpdating = False
    lRw = Sheet1.Cells(Rows.Count, "A").End(xlUp).Row
    ThisWorkbook.Sheets("Sheet1").Activate

    For i = 1 To lRw
        Range("A" & i).Copy
        lRw_2 = Sheets("Sheet2").Cells(Rows.Count, "B").End(xlUp).Row + 1
        Sheets("Sheet1").Activate
        'I not sure for this one, the code is too long
            Select Case ThisWorkbook.Sheets("sheet1").Range("A" & i).Value
            Case "Animal"
            With Sheets("Sheet2").Range("B" & lRw_2)
            .Value = 1
            End With
            Case "Plant"
            With Sheets("Sheet2").Range("B" & lRw_2)
            .Value = 2
            End With
            Case "Rock"
            With Sheets("Sheet2").Range("B" & lRw_2)
            .Value = 3
            End With
            Case "Sand"
            With Sheets("Sheet2").Range("B" & lRw_2)
            .Value = 4
            End With
            End Select
        Sheets("Sheet1").Activate
    Next i
    Application.ScreenUpdating = True
End Sub

Thanks in advance.

What problem are you having? Does the above code give you an error? If so, what error and on which line of code? If it doesn't have any errors and you simply want advice on improving the code, this question should be migrated to Code Review. — puzzlepiece87
The code above not give me an error..you are right... i want improve the code. Perhaps anyone could give me same things with simple code. I'm just thinking if the range with many data ie 2.000 cells or more? I'm sure my excel can work slowly.. Have you any advice..? — Ryan Chatoeala

paul bica paul bica · Accepted Answer · 2017-06-04T04:21:42

Try this:

Option Explicit

Public Sub replaceItems()
    Application.ScreenUpdating = False
    With Sheets(2).Range("B1:B100")
        .Value2 = Sheets(1).Range("A1:A100").Value2
        .Replace What:="Animal", Replacement:=1, LookAt:=xlWhole
        .Replace What:="Plant", Replacement:=2, LookAt:=xlWhole
        .Replace What:="Rock", Replacement:=3, LookAt:=xlWhole
        .Replace What:="Sand", Replacement:=4, LookAt:=xlWhole
    End With
    Application.ScreenUpdating = True
End Sub

VBA - Excel Copy and paste range with criteria

1 Answers