Question

我想要复制Sheet1范围A1：A100中的范围，其中每个单元格中填充的值如“Animal”，“Plant”，“Rock”和“Sand”。然后，我想在Sheet2范围B1：B100中粘贴条件，如果范围A1：A100的值是“Animal”粘贴“1”，如果值是“Plant”粘贴“2”，等等。

我如何编写VBA代码？简单且减少内存使用量。我的代码：

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

提前致谢。

Answer 1

试试这个：

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使用条件复制和粘贴范围

1 个答案: