Вернулся без ответа - Копирование и вставка в определенный диапазон ячеек на основе выбора из выпадающего списка

Question

РЕДАКТИРОВАТЬ 2/10/18 - 22: 45

Я говорил слишком рано раньше и обновил свой первоначальный пост.Хотя я думал, что эта проблема была в основном решена, я теперь видел, что цели копируются из Objectives Entry Sheet и вставляются в каждый раздел - осень, весна и лето - на лист Data Validation независимо от того, где они введены вData Validation Sheet.

Например, если я ввожу текст в F13 - ячейка «Осень, год 1, цель 1», нажатие кнопки «Обновить» копирует текст на лист проверки данных в ячейки D19, J19 и P19 -ячейки «Задача 1 года 1, года и весны 1 года»

Кто-нибудь может подсказать, что является причиной этого?

Option Explicit

Sub SubjectObjectives()
    Dim srcWs As Worksheet
    Dim trgWs As Worksheet
    Dim dvCell As Range
    Dim AutSrc As Range, SprSrc As Range, SumSrc As Range
    Dim Art As Range, Computing As Range, DT As Range, Geography As Range, History As Range, MFL As Range, Music As Range, PE As Range, RE As Range, Science As Range
    Dim AutTarget As Range, SprTarget As Range, SumTarget As Range
    Dim cell As Range
    Dim hLink As Hyperlink

'Set source and target worksheets
    Set srcWs = Worksheets("Objectives Entry Sheet")
    Set trgWs = Worksheets("Data Validation")

'Set cell where Dropdown list is
    Set dvCell = Worksheets("Objectives Entry Sheet").Range("B11")

'Set where objectives are copied from
    Set AutSrc = srcWs.Range("F13:K18")
    Set SprSrc = srcWs.Range("F23:K28")
    Set SumSrc = srcWs.Range("F33:K38")

'Set where objectives are copied to

    If dvCell = "" Then GoTo Whoops

    If dvCell.Value = "Art" Then Set AutTarget = trgWs.Range("D19:U24")
    If dvCell.Value = "Art" Then Set SprTarget = trgWs.Range("J19:O24")
    If dvCell.Value = "Art" Then Set SumTarget = trgWs.Range("P19:U24")

    If dvCell.Value = "Computing" Then Set AutTarget = trgWs.Range("D25:U30")
    If dvCell.Value = "Computing" Then Set SprTarget = trgWs.Range("J25:O30")
    If dvCell.Value = "Computing" Then Set SumTarget = trgWs.Range("P25:U30")

    If dvCell.Value = "DT" Then Set AutTarget = trgWs.Range("D31:U36")
    If dvCell.Value = "DT" Then Set SprTarget = trgWs.Range("J31:O36")
    If dvCell.Value = "DT" Then Set SumTarget = trgWs.Range("P31:U36")

    If dvCell.Value = "Geography" Then Set AutTarget = trgWs.Range("D37:U42")
    If dvCell.Value = "Geography" Then Set SprTarget = trgWs.Range("J37:O42")
    If dvCell.Value = "Geography" Then Set SumTarget = trgWs.Range("P37:U42")

    If dvCell.Value = "History" Then Set AutTarget = trgWs.Range("D43:U48")
    If dvCell.Value = "History" Then Set SprTarget = trgWs.Range("J43:O48")
    If dvCell.Value = "History" Then Set SumTarget = trgWs.Range("P43:U48")

    If dvCell.Value = "MFL" Then Set AutTarget = trgWs.Range("D49:U54")
    If dvCell.Value = "MFL" Then Set SprTarget = trgWs.Range("J49:O54")
    If dvCell.Value = "MFL" Then Set SumTarget = trgWs.Range("P49:U54")

    If dvCell.Value = "Music" Then Set AutTarget = trgWs.Range("D55:U60")
    If dvCell.Value = "Music" Then Set SprTarget = trgWs.Range("J55:O60")
    If dvCell.Value = "Music" Then Set SumTarget = trgWs.Range("P55:U60")

    If dvCell.Value = "PE" Then Set AutTarget = trgWs.Range("D61:U66")
    If dvCell.Value = "PE" Then Set SprTarget = trgWs.Range("J61:O66")
    If dvCell.Value = "PE" Then Set SumTarget = trgWs.Range("P61:U66")

    If dvCell.Value = "RE" Then Set AutTarget = trgWs.Range("D67:U72")
    If dvCell.Value = "RE" Then Set SprTarget = trgWs.Range("J67:O72")
    If dvCell.Value = "RE" Then Set SumTarget = trgWs.Range("P67:U72")

    If dvCell.Value = "Science" Then Set AutTarget = trgWs.Range("D73:U78")
    If dvCell.Value = "Science" Then Set SprTarget = trgWs.Range("J73:O78")
    If dvCell.Value = "Science" Then Set SumTarget = trgWs.Range("P73:U78")

    Application.ScreenUpdating = False

       'Copy cell contents

            AutSrc.Copy
            AutTarget.PasteSpecial xlValues, skipblanks:=True
            AutSrc.ClearContents

            SprSrc.Copy
            SprTarget.PasteSpecial xlValues, skipblanks:=True
            SprSrc.ClearContents

            SumSrc.Copy
            SumTarget.PasteSpecial xlValues, skipblanks:=True
            SumSrc.ClearContents


    Application.CutCopyMode = False

    Application.ScreenUpdating = True

Exit Sub

Whoops:
    MsgBox "Please select a subject from the dropdown menu and press 'Update' again."

End Sub

Я хочу, чтобы пользователи могли выбирать тему, к которой они относятсявведите цели для из раскрывающегося списка на листе Objectives Entry Sheet , введите цели в некоторые или все ячейки в разделах Осень, Весна и Летний семестр, а затем нажмите Обновление кнопка, чтобы скопировать эти цели в соответствующий диапазон ячеек (на основе темы и термина) в Листе проверки данных .

Кроме того, существует ли способ указать, что любые гиперссылки, создаваемые в листе ввода цели, сохраняются, когда ячейкасодержимое копируется в лист проверки данных, так как эти ячейки будут использоваться для заполнения других таблиц.

Файл доступен здесь .

Может кто-нибудь помочь?

Answer 1

Ваш для каждого цикла не работает, как предполагалось.

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

Во-вторых, он вставляет пустые ячейки.

Я не волшебник, но я хотел бы сделать что-то вроде этого:

nRows = autSrc.rows.count

nCols = autSrc.columns.count

for i = 1 to nrows
    for k = 1 to nCols
        if autSrc.cells(i,k) <> "" then

            target.cells(i,k) = autSrc.cells(i,k)            

        end if
    next k
next i 

Редактировать: Далее, я бы просто указал, что ваш код не учитывает разные сезоны, насколько ямогу сказать.

Answer 2

Я удалил цикл проверки пустых ячеек и вместо этого изменил его на «skipBlanks = true» в методе pasteSpecial.У меня работает!

Option Explicit

Sub SubjectObjectives()
    Dim srcWs As Worksheet
    Dim trgWs As Worksheet
    Dim dvCell As Range
    Dim AutSrc As Range, SprSrc As Range, SumSrc As Range
    Dim Art As Range, Computing As Range, DT As Range, Geography As Range, History As Range, MFL As Range, Music As Range, PE As Range, RE As Range, Science As Range
    Dim Target As Range
    Dim cell As Range

'Set source and target worksheets
    Set srcWs = Worksheets("Objectives Entry Sheet")
    Set trgWs = Worksheets("Data Validation")

'Set cell where Dropdown list is
    Set dvCell = Worksheets("Objectives Entry Sheet").Range("B11")

'Set where objectives are copied from
    Set AutSrc = srcWs.Range("F13:K18")
    Set SprSrc = srcWs.Range("F23:K28")
    Set SumSrc = srcWs.Range("F33:K38")

'Set where objectives are copied to
    If dvCell.Value = "Art" Then Set Target = trgWs.Range("D19:I24")
    If dvCell.Value = "Computing" Then Set Target = trgWs.Range("D25:I30")
    If dvCell.Value = "DT" Then Set Target = trgWs.Range("D31:I36")
    If dvCell.Value = "Geography" Then Set Target = trgWs.Range("D37:I42")
    If dvCell.Value = "History" Then Set Target = trgWs.Range("D43:I48")
    If dvCell.Value = "MFL" Then Set Target = trgWs.Range("D49:I54")
    If dvCell.Value = "Music" Then Set Target = trgWs.Range("D55:I60")
    If dvCell.Value = "PE" Then Set Target = trgWs.Range("D61:I66")
    If dvCell.Value = "RE" Then Set Target = trgWs.Range("D67:I72")
    If dvCell.Value = "Science" Then Set Target = trgWs.Range("D73:I78")

'Begin loop
    Application.ScreenUpdating = False

      '  For Each cell In AutSrc

     '   If cell.Value <> "" Then

            AutSrc.Copy
            Target.PasteSpecial xlValues, skipBlanks:=True
      '  End If

       ' Next cell


Application.ScreenUpdating = True

End Sub