從範圍的一個表粘貼部分基於單元格值在另一個表相同的薄層

現在我已經創建了一個代碼，以基於從另一片材（副本和值從一個範圍中的值複製到另一個範圍複製範圍粘貼發生在一張紙上）。從範圍的一個表粘貼部分基於單元格值在另一個表相同的薄層

但是因爲這個值可以是12個值中的一個，正被複制和粘貼的範圍內變小。

由於我不擅長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

來源

2014-02-18 user979226

你能提供至少兩個或三個副本*** ***都和一個名爲範圍內粘貼的地址？如果有一個模式，這將是非常容易優化。 :) – Manhattan

的另一種方法，這一個靈活得多並且更容易更新：

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就夠了。

讓我們知道這是否有幫助。

來源

2014-02-18 20:16:04 Manhattan

上面的代碼非常好，但是當它粘貼反向粘貼時，應該只將這些列粘貼到範圍的右側，它會正確複製，但不能在範圍內正確粘貼。看看我是否可以弄清楚。 – user979226

啊想出來了，當我複製上面的代碼時，錯過了strNum，謝謝！ – user979226

如果它對您有幫助，請將其標記爲已接受。這就是我們如何在SO中表示感謝。 :) – Manhattan

有沒有辦法讓我的代碼更加優化，並命名爲少在我的工作簿範圍？

取決於你的數據組織方式。但現在，你可以稍微簡化代碼：

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

來源

2014-02-18 19:04:49

+1：我對此也有完全的瞭解，但我正在考慮他的「減少命名範圍」這一行。如果他的範圍沒有模式，這是最好的。易於維護，以及。 – Manhattan

使用字符串操作和一個循環，你可以大大減少代碼的大小：

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」 ......

（11×11串）你可以使用在這個陣列中的雙環：

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

並且可以創建這樣海峽= 「CopyFormulasFT」字符串+ arrstrings（ⅰ）+ arrstrings（J）

來源

2014-02-18 19:24:55 Pedrumj

我真誠地建議您在獲得downvoted之前編輯上述內容。正如你所看到的，從他複製的地方到他粘貼的地方都來自*不同的*表格並且有*不同的名字。除非你編輯上面的字符串和你的迭代器'i'一起改變，這不是一個適用的答案。儘管如此，我不會倒退，因爲邏輯非常合理，但是應用程序有點不合適。 – Manhattan

感謝沒有看到那裏的不同字符串 – Pedrumj

+1：其實，我對不同的表格是錯誤的，但確實是用不同的名字修正的。 – Manhattan

從範圍的一個表粘貼部分基於單元格值在另一個表相同的薄層

回答

相關問題