从一个工作表复制范围根据另一工作表上的单元格值将部分范围粘贴到同一工作表中答案

【问题标题】：Copy Range From One Sheet Paste Part of Range In Same Sheet Based On Cell Value On Another Sheet从一个工作表复制范围根据另一工作表上的单元格值将部分范围粘贴到同一工作表中
【发布时间】：2014-02-18 18:55:47
【问题描述】：

现在我已经创建了一个代码，用于根据另一张纸上的值将值从一个范围复制到另一个范围（复制和粘贴发生在一张纸上）。

但是因为这个值可以是十二个值之一，所以被复制和粘贴的范围会变小。

因为我不擅长 VBA，所以我在 Excel 中创建了几十个复制范围和几十个粘贴范围，以通过 VBA 处理 ElseIf 语句，以根据其他工作表中的单元格值进行复制和粘贴。

我很好奇，有没有办法让我的代码更加优化并在我的工作簿中减少命名范围？

任何帮助将不胜感激，这是我粘贴在下面的代码（复制和粘贴的每个命名范围都只是少一列，因为选择可以在第一张表中）：

SubTest()

If ws0.Range("D6") = "BUD" Then    
    ws1.Range("CopyFormulasFT").Select
    Selection.Copy
    ws1.Range("PasteFormulasFT").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
        SkipBlanks:=True, Transpose:=False

ElseIf ws0.Range("D6") = "F01" Then
    ws1.Range("CopyFormulasFTOneEleven").Select
    Selection.Copy
    ws1.Range("PasteFormulasFTOneEleven").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
        SkipBlanks:=True, Transpose:=False

ElseIf ws0.Range("D6") = "F02" Then
    ws1.Range("CopyFormulasFTTwoTen").Select
    Selection.Copy
    ws1.Range("PasteFormulasFTTwoTen").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
        SkipBlanks:=True, Transpose:=False

ElseIf ws0.Range("D6") = "F03" Then
    ws1.Range("CopyFormulasFTThreeNine").Select
    Selection.Copy
    ws1.Range("PasteFormulasFTThreeNine").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
        SkipBlanks:=True, Transpose:=False

ElseIf ws0.Range("D6") = "F04" Then
    ws1.Range("CopyFormulasFTFourEight").Select
    Selection.Copy
    ws1.Range("PasteFormulasFTFourEight").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
        SkipBlanks:=True, Transpose:=False

ElseIf ws0.Range("D6") = "F05" Then
    ws1.Range("CopyFormulasFTFiveSeven").Select
    Selection.Copy
    ws1.Range("PasteFormulasFTFiveSeven").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
        SkipBlanks:=True, Transpose:=False

ElseIf ws0.Range("D6") = "F06" Then
    ws1.Range("CopyFormulasFTSixSix").Select
    Selection.Copy
    ws1.Range("PasteFormulasFTSixSix").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
        SkipBlanks:=True, Transpose:=False

ElseIf ws0.Range("D6") = "F07" Then
    ws1.Range("CopyFormulasFTSevenFive").Select
    Selection.Copy
    ws1.Range("PasteFormulasFTSevenFive").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
        SkipBlanks:=True, Transpose:=False

ElseIf ws0.Range("D6") = "F08" Then
    ws1.Range("CopyFormulasFTEightFour").Select
    Selection.Copy
    ws1.Range("PasteFormulasFTEightFour").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
        SkipBlanks:=True, Transpose:=False

ElseIf ws0.Range("D6") = "F09" Then
    ws1.Range("CopyFormulasFTNineThree").Select
    Selection.Copy
    ws1.Range("PasteFormulasFTNineThree").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
        SkipBlanks:=True, Transpose:=False

ElseIf ws0.Range("D6") = "F10" Then
    ws1.Range("CopyFormulasFTTenTwo").Select
    Selection.Copy
    ws1.Range("PasteFormulasFTTenTwo").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
        SkipBlanks:=True, Transpose:=False

ElseIf ws0.Range("D6") = "F11" Then
    ws1.Range("CopyFormulasFTElevenOne").Select
    Selection.Copy
    ws1.Range("PasteFormulasFTElevenOne").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
        SkipBlanks:=True, Transpose:=False

End If

End Sub

【问题讨论】：

您能否提供至少两个或三个 both 复制和粘贴命名范围的地址？如果有模式，这将很容易优化。 :)

标签： vba excel copy-paste named-ranges

【解决方案1】：

使用字符串操作和循环可以大大减少代码的大小：

dim arrStrings(1 to 11) as string
arrStrings(1) = "OneEleven"
arrStrings(2) = "TwoTen"
arrStrings(2) = "ThreeNine"
...
arrStrings(11) = "NineThree"

 dim  i as integer
    for i = 1 to 11
        If ws0.Range("D6") = "F"+ strings.trim(str(i)) Then
             ws1.Range("CopyFormulasFT" + arrStrings(i)).Select
             Selection.Copy
             ws1.Range("PasteFormulasFT" + arrStrigns(i)).Select
             Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
             SkipBlanks:=True, Transpose:=False
        end if
    next i

如果实际代码是这样的

“oneone”、“onetwo”、“onethree”、...、“oneeleven”、“twoone”、“twotwo”、“twothree”、...“twoeleven”...

（11x11 字符串）你可以在这个数组上使用双循环：

dim arrStrings(1 to 11) as string
arrStrings(1) = "One"
arrStrings(2) = "Two"
arrStrings(2) = "Three"
...
arrStrings(11) = "Nine"

你可以像这样创建字符串 Str = "CopyFormulasFT"+ arrstrings(i) + arrstrings(j)

【讨论】：

我真诚地建议您在被否决之前编辑以上内容。如您所见，他正在复制和粘贴的范围来自不同的工作表，并且具有不同的名称。除非您编辑上述字符串以随迭代器 i 一起更改，否则这不是一个适用的答案。不过，我不会投反对票，因为逻辑非常合理，但应用程序有点过时。
谢谢没有看到不同的字符串
+1：实际上，我对不同的工作表有误，但对不同的名称确实是正确的。

【解决方案2】：

另一种方法，这个更灵活且更容易更新：

Sub CondCopy()

    Dim ws0 As Worksheet, ws1 As Worksheet
    Dim str0 As String, str1 As String, str2 As String
    Dim strCond As String, ArrLoc As Long
    Dim strCopy As String, strPaste As String, strNum As String

    With ThisWorkbook
        Set ws0 = .Sheets("Sheet1")
        Set ws1 = .Sheets("Sheet2")
    End With

    str0 = ";One;Two;Three;Four;Five;Six;Seven;Eight;Nine;Ten;Eleven"
    str1 = ";Eleven;Ten;Nine;Eight;Seven;Six;Five;Four;Three;Two;One"
    str2 = "BUD;F01;F02;F03;F04;F05;F06;F07;F08;F09;F10;F11"
    strCond = ws0.Range("D6").Value

    ArrLoc = Application.Match(strCond, Split(str2, ";"), 0) - 1
    strNum = Split(str0, ";")(ArrLoc) & Split(str1, ";")(ArrLoc)

    strCopy = "CopyFormulasFT" & strNum
    strPaste = "PasteFormulasFT" & strNum

    With ws1
        .Range(strCopy).Copy
        .Range(strPaste).PasteSpecial xlPasteValues, SkipBlanks:=True
    End With

End Sub

如果您需要按照模式添加更多命名范围，只需编辑str0、str1 和str2 就足够了。

如果这有帮助，请告诉我们。

【讨论】：

上面的代码很棒，但是当它粘贴时，它会倒转粘贴，应该只将列粘贴到范围的右侧，它是在适当地复制而不是在范围内适当地粘贴。看看我能不能弄明白。
啊，搞清楚了，复制上面的代码时缺少strNum，谢谢！
问题，我有另一段代码试图使用您的上述代码进行操作，但是我不断收到“对象工作表范围失败”错误。
感谢您的接受。 :) 如果它与这个不同的代码或问题，请开始一个新问题。 :)
刚刚在这里：stackoverflow.com/questions/21866608/… 谢谢 BK201 :)

【解决方案3】：

有没有办法让我的代码更加优化并在我的工作簿中减少命名范围？

取决于您的数据的组织方式。但是现在，您可以稍微简化一下代码：

Sub Test()
    Dim destRng As String
    Dim sorceRng As String

    Select Case ws0.Range("D6")
        Case "BUD"
            sorceRng = "CopyFormulasFT": destRng = "PasteFormulasFT"
        Case "F01"
            sorceRng = "CopyFormulasFTOneEleven": destRng = "PasteFormulasFTOneEleven"
        Case "F02"
            sorceRng = "CopyFormulasFTTwoTen": destRng = "PasteFormulasFTTwoTen"
        Case "F03"
            sorceRng = "CopyFormulasFTThreeNine": destRng = "PasteFormulasFTThreeNine"
        Case "F04"
            sorceRng = "CopyFormulasFTFourEight": destRng = "PasteFormulasFTFourEight"
        Case "F05"
            sorceRng = "CopyFormulasFTFiveSeven": destRng = "PasteFormulasFTFiveSeven"
        Case "F06"
            sorceRng = "CopyFormulasFTSixSix": destRng = "PasteFormulasFTSixSix"
        Case "F07"
            sorceRng = "CopyFormulasFTSevenFive": destRng = "PasteFormulasFTSevenFive"
        Case "F08"
            sorceRng = "CopyFormulasFTEightFour": destRng = "PasteFormulasFTEightFour"
        Case "F09"
            sorceRng = "CopyFormulasFTNineThree": destRng = "PasteFormulasFTNineThree"
        Case "F10"
            sorceRng = "CopyFormulasFTTenTwo": destRng = "PasteFormulasFTTenTwo"
        Case "F11"
            sorceRng = "CopyFormulasFTElevenOne": destRng = "PasteFormulasFTElevenOne"
        Case Else
            Exit Sub
    End Select

    ws1.Range(sorceRng).Copy
    ws1.Range(destRng).PasteSpecial Paste:=xlPasteValues, SkipBlanks:=True

End Sub

【讨论】：

+1：我也有这个，但我也在考虑他的行“减少命名范围”。如果他的范围没有模式，这是最好的。也易于维护。