Копировать диапазон с одного листа Вставить часть диапазона на том же листе на основе значения ячейки на другом листе

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

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

Поскольку я не разбираюсь в 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

excel named-ranges copy-paste vba
person user979226    schedule 18.02.2014    source источник
comment
Можете ли вы указать адреса хотя бы двух или трех из обоих именованного диапазона "Копировать" и "Вставить"? Если есть шаблон, его будет очень легко оптимизировать. :)   -  person NullDev    schedule 18.02.2014

Ответы (3)


arrow_upward
2
arrow_downward

Другой подход, гораздо более гибкий и простой в обновлении:

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.

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

person NullDev    schedule 18.02.2014
comment
Этот приведенный выше код великолепен, однако, когда он вставляет, он вставляет инвертированный, должен вставлять только столбцы справа от диапазона, он копирует соответствующим образом, но не вставляет должным образом в пределах диапазона. Хочу посмотреть, смогу ли я это понять. - person user979226; 19.02.2014
comment
Ах, понял, не хватало strNum, когда я скопировал приведенный выше код, спасибо! - person user979226; 19.02.2014
comment
Вопрос, у меня был еще один фрагмент кода, которым я пытался манипулировать, используя ваш приведенный выше код, но я продолжаю получать ошибку Range of object workheet failed. - person user979226; 19.02.2014
comment
Спасибо, что приняли. :) Пожалуйста, начните новый вопрос, если это другой код или проблема, отличная от этого. :) - person NullDev; 19.02.2014
comment
Только что сделал здесь: stackoverflow.com/questions/21866608/ Спасибо BK201 :) - person user979226; 19.02.2014

arrow_upward
3
arrow_downward

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

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», «oneeleven»,…, «oneeleven», «twoone», «twoeleven», «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)

person Pedrumj    schedule 18.02.2014
comment
Я искренне предлагаю отредактировать приведенное выше, прежде чем вы получите голос против. Как видите, диапазон, откуда он копирует и куда он вставляет, взят из разных листов и имеет разные имена. Если вы не отредактируете приведенные выше строки, чтобы они изменились вместе с вашим итератором i, это неприменимый ответ. Я не буду понижать голос, потому что логика неплохая, но приложение не работает. - person NullDev; 18.02.2014
comment
Спасибо, не видел там разных строк - person Pedrumj; 18.02.2014
comment
+1: На самом деле, я ошибался с разными листами, но действительно прав с разными именами. - person NullDev; 19.02.2014

arrow_upward
2
arrow_downward

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

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

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
person Dmitry Pavliv    schedule 18.02.2014
comment
+1: У меня есть именно это и на моем конце, но я думаю о его линии, чтобы уменьшить названные диапазоны. Если у него нет шаблона для его диапазонов, это лучший вариант. К тому же прост в обслуживании. - person NullDev; 18.02.2014