excel vb dropdownlist更新

我希望有人能帮上忙。 我有B：3中的下拉列表的源工作簿和B10：K50中的数据。 Workbook2; 目标工作簿是从我需要运行代码的位置开始的，这也是我从源代码wb dropdownlist中获取具有相同名称的所有工作表的地方。

我想达到的是:::通过dropdownlist工作是源wb，更新下拉列表值的数据，复制范围B10：K50，打开目标工作簿，find工作表名称（从下拉列表文本相同），并从A1粘贴数据。

回到源wb并重复，直到从下拉列表中的最后一个值。 我正在使用的代码是低于但问题是它只是没有更新B：3中的dropdownlist值：

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. 避免使用激活和select是一个好习惯。 相反，定义明确你想要使用的对象。 在下面的代码中，我定义了一个SourceWB（源工作簿），一个DestWB（目标工作簿），一个SourceSht（在SourceWB中具有所需信息的工作表）和一个DestSht（存放信息的DestWB中的工作表）。 在代码的“初始”部分，您将需要相应地更改名称 – 我使用的名称符合我以前testing的小问题。
2. 您试图强制SourceSht中的B3值改变。 在下面的代码中，我find了用于B3的validation列表的范围，并直接使用该范围内的数据。
3. 在您的代码中，您假设存在表单名称（如validation列表范围中定义的）。 我检查它是否存在，如果没有，则创build表单。
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…

 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 

---

更新 – 基于不使用命名范围进行validation

如果使用命名范围或范围参考来validation单元格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