Excel vbドロップダウンリストの更新

Question

私はmewbieここに誰かが助けることを願っています。 B：3のドロップダウンリストとB10：K50のデータを持つソースワークブックがあります。 Workbook2;宛先ワークブックはどこからコードを実行する必要があるのか​​、これはソースwbのドロップダウンリストと同じ名前のシートがすべてある場所です。

私が達成したいのは:::ドロップダウンリストはソースwbであり、ドロップダウンリストの値を変更し、範囲をコピーします。B10：K50、コピー先のブックを開き、シート名を見つけます（ドロップダウンリストのテキストと同じです） A1からのデータ。

ソースwbに戻り、ドロップダウンリストの最後の値まで繰り返します。私が使用していたコードは以下の通りですが、問題はそれだけでBにDropDownListコントロール値を更新していないです：3：

Dim inputRange As Range 
Dim c As Range 
Dim WS_Count As Integer 
Dim I As Integer 
WS_Count = ActiveWorkbook.Worksheets.Count 
Dim Source As Range 
Dim dd As DropDown 
'Worksheets("Refurbs Tracker.xlsx").Select 
Windows("Refurbs Tracker.xlsx").Activate 
'[B3] = c.Value 
'Worksheets("Refurbs Tracker.xlsx").Select 
''Range("B3").Select******************************************************************************* 
    Set inputRange = Evaluate(Range("B3").Validation.Formula1) 
    '''***********************************************************Range("B3").Value = c.Value 
For Each c In inputRange 
    [B3] = c.Value 
    'Range("B3").Value = c.Value 
    'you might need to refresh the sheet here 
    ActiveSheet.Calculate 
    'Copy and PasteSpecial between workbooks 

    Workbooks("Refurbs Tracker.xlsx").Worksheets("Front Sheet").Range("b1:k50").Copy 
    Windows("Combined.xlsm").Activate 
    Sheets(c.Value).Select 
    'Sheets("151 MC Paisley").Select 
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ 
    :=False, Transpose:=False 
    Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _ 
    SkipBlanks:=False, Transpose:=False 
    Cells.Select 
    Cells.EntireColumn.AutoFit 
    Range("A1").Select 
    ' Begin the loop. 
    'For I = 1 To WS_Count 

    'ThisWorkbook.Worksheets(I).Select 
    'Source.Copy 
    'Range("B1:K50").Select 
    'ActiveSheet.Paste 

    'Next I 
Next c 
'Disable marching ants around copied range 
Application.CutCopyMode = False 

Answer 1

それはあなたが多くのことを試してみました、あなたのコードから明らかです。いくつかのコメント：

1. アクティブ化と選択を避けることをお勧めします。代わりに、明示的に使用するオブジェクトを定義します。以下のコードでは、SourceWB（ソースブック）、DestWB（宛先ワークブック）、SourceSht（SourceWBに必要な情報を含むシート）、DestSht（DestWB内の情報が格納されるシート）を定義しました。コードの「初期」セクションでは、名前を適宜変更する必要があります。テストに使用した小さな問題に合った名前を使用しました。
2. SourceShtにB3の値を強制的に変更しようとしました。このアプローチの代わりに、以下のコードでB3に使用される検証リストの範囲を見つけて、その範囲から直接データを使用しています。
3. コードでは、（検証リストの範囲で定義されている）シート名が存在すると想定しています。私はそれが存在することを確認しており、そうでなければシートを作成しています。
4. 他のアクションを検討することもできます。値を貼り付ける前に宛先シート内のデータを消去します。ルーチンの先頭にApplication.ScreenUpdating = False、末尾にApplication.ScreenUpdating = Trueを設定すると、点滅する画面が表示されなくなります。

コード ...

Sub myTest() 
Dim SourceWB As Workbook, DestWB As Workbook 
Dim SourceSht As Worksheet, DestSht As Worksheet 
Dim c As Range, myListRng As Range 
Dim myListStr As String 

' Initial 
    Set SourceWB = Workbooks("Book1") ' <~~ Use your Source Workbook name - "Refurbs Tracker" ? 
    Set DestWB = Workbooks("Book2")  ' <~~ Use your Destination Workbook name - "Combined" ? 
    Set SourceSht = SourceWB.Worksheets("Sheet1") ' <~~ Use your Source Sheet name - "Front Sheet" ? 

' find the drop down values 
    If SourceSht.Range("B3").Validation.Type = xlValidateList Then 
     myListStr = Mid(SourceSht.Range("B3").Validation.Formula1, 2) 
     Set myListRng = SourceWB.Names(myListStr).RefersToRange 
    Else 
     MsgBox "Problem with Validation List" 
     Exit Sub 
    End If 

' loop through the drop down values and do work 
    For Each c In myListRng 
     If SheetExists(c.Value, DestWB) Then 
      Set DestSht = DestWB.Worksheets(c.Value) 
     Else 
      Set DestSht = DestWB.Worksheets.Add 
      DestSht.Name = c.Value 
     End If 
     SourceSht.Range("B10:K50").Copy 
     DestSht.Range("A1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _ 
      SkipBlanks:=False, Transpose:=False 
    Next c 
    Application.CutCopyMode = False 

' Clean up 
    Set SourceSht = Nothing 
    Set DestSht = Nothing 
    Set SourceWB = Nothing 
    Set DestWB = Nothing 

End Sub 

...と支持機能...

Function SheetExists(Name As String, WB As Workbook) As Boolean 
Dim WS As Worksheet 
    SheetExists = False 
    For Each WS In WB.Worksheets 
     If Name = WS.Name Then 
      SheetExists = True 
      GoTo CleanUp: 
     End If 
    Next WS 
CleanUp: 
    Set WS = Nothing 
End Function 

---

アップデート - 検証用の名前付き範囲を使用していないに基づいて、

以下のコード名前付き範囲または範囲参照がセルB3の検証に使用されている場合に機能します。

Sub myTest() 
Dim SourceWB As Workbook, DestWB As Workbook 
Dim SourceSht As Worksheet, DestSht As Worksheet 
Dim c As Range, myListRng As Range 
Dim myListStr As String, myShtStr As String, myRngStr As String 

' Initial 
    Set SourceWB = Workbooks("Book1") ' <~~ Use your Source Workbook name - "Refurbs Tracker" ? 
    Set DestWB = Workbooks("Book2")  ' <~~ Use your Destination Workbook name - "Combined" ? 
    Set SourceSht = SourceWB.Worksheets("Sheet1") ' <~~ Use your Source Sheet name - "Front Sheet" ? 

' find the drop down values 
    If SourceSht.Range("B3").Validation.Type = xlValidateList Then 
     myListStr = Mid(SourceSht.Range("B3").Validation.Formula1, 2) 
     On Error Resume Next 
     Set myListRng = SourceWB.Names(myListStr).RefersToRange 
     If Err.Number <> 0 Then 
      myShtStr = Left(myListStr, InStr(1, myListStr, "!") - 1) 
      myRngStr = Right(myListStr, Len(myListStr) - Len(myShtStr) - 1) 
      myShtStr = Replace(myShtStr, "'", "") 
      Set myListRng = SourceWB.Worksheets(myShtStr).Range(myRngStr) 
     End If 
     On Error GoTo 0 
    Else 
     MsgBox "Problem with Validation List" 
     Exit Sub 
    End If 

' loop through the drop down values and do work 
    For Each c In myListRng 
     If SheetExists(c.Value, DestWB) Then 
      Set DestSht = DestWB.Worksheets(c.Value) 
     Else 
      Set DestSht = DestWB.Worksheets.Add 
      DestSht.Name = c.Value 
     End If 
     SourceSht.Range("B10:K50").Copy 
     DestSht.Range("A1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _ 
      SkipBlanks:=False, Transpose:=False 
    Next c 
    Application.CutCopyMode = False 

' Clean up 
    Set SourceSht = Nothing 
    Set DestSht = Nothing 
    Set SourceWB = Nothing 
    Set DestWB = Nothing 

End Sub