VBA - Excel 复制和粘贴范围与标准答案

【问题标题】：VBA - Excel Copy and paste range with criteriaVBA - Excel 复制和粘贴范围与标准
【发布时间】：2017-06-04 01:39:31
【问题描述】：

我想在 Sheet1 范围 A1:A100 中复制一个范围，其中每个单元格中都填充有“动物”、“植物”、“岩石”和“沙子”等值。然后，如果范围 A1:A100 的值是“动物”粘贴“1”，我想粘贴在 Sheet2 范围 B1:B100 中，如果值是“植物”粘贴“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

提前致谢。

【问题讨论】：

请展示您的尝试。
你有什么问题？上面的代码会给你一个错误吗？如果是这样，什么错误以及在哪一行代码？如果它没有任何错误，并且您只是想要改进代码的建议，则应将此问题迁移到 Code Review。
上面的代码没有给我一个错误..你是对的......我想改进代码。也许任何人都可以用简单的代码给我同样的东西。我只是在想，如果有很多数据的范围，即 2.000 个单元格或更多？我确信我的 excel 可以运行缓慢..你有什么建议..？

标签： vba excel

【解决方案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

【讨论】：

感谢代码，它正在工作。它是如此简单的代码。 :-)