Диапазон копирования из одной листовой пасты Часть диапазона на одном листе на основе значения ячейки на другом листе

Question

В настоящее время я создал код для копирования значений из одного диапазона в другой диапазон на основе значения с другого листа (копия и паста происходит на одном листе).

Но поскольку это значение может быть одним из двенадцати значений, диапазон, который копируется и вставляется, становится меньше.

Поскольку я не разбираюсь в VBA, я создал десятки диапазонов копий и десятки диапазонов палитры в Excel для обработки инструкций ElseIf через VBA для копирования и вставки в зависимости от того, что значение ячейки находится на другом листе.

Мне любопытно, есть ли способ сделать мой код более оптимизированным и иметь меньше названных диапазонов в моей книге?

Любая помощь будет оценена, вот мой код вставили ниже (каждый именованный диапазон как для копирования и вставки просто один меньше столбец из-за того, что выборы могут быть в первом листе):

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 

Answer 1

Другой подход, это один гораздо более гибким и легче обновлять:

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 достаточно.

Сообщите нам, если это поможет.

Answer 2

есть ли способ сделать мой код более оптимизированным и иметь меньше названных диапазонов в моей книге?

зависит от того, как организованы ваши данные. Но теперь, вы можете немного упростить код:

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 

Answer 3

Использование манипуляции со строками и цикл можно значительно уменьшить размер этого кода:

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" 

и вы можете создать строку, как этот Str = "CopyFormulasFT" + arrstrings (I) + arrstrings (J)