VBA - Excel Kopieren und Einfügen Bereich mit Kriterien

Question

Ich möchte einen Bereich in Sheet1 Bereich A1: A100, wo in jeder Zelle mit Wert wie "Animal", "Plant", "Rock" und "Sand" gefüllt werden. Dann möchte ich einfügen in Sheet2 Bereich B1: B100 mit Bedingungen, wenn der Wert im Bereich A1: A100 ist "Animal" einfügen mit "1", wenn der Wert "Plant" einfügen mit "2", ect.

Wie schreibe ich den VBA-Code? Mit einfacher und reduzierter Speichernutzung. Mein 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 

Vielen Dank im Voraus.

Answer 1

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