Question

我在这里有一个mewbie希望有人可以提供帮助。我的源工作簿有B：3中的下拉列表和B10：K50中的数据。 Workbook2;目标工作簿是我需要运行代码的地方，这也是我从源wb下拉列表中获得所有相同名称的工作表。

我想要实现的是:::通过dropdownlist工作是源wb，更新数据depanding on dropdownlist值，复制范围B10：K50，打开目标工作簿，查找工作表名称（与下拉列表文本相同）并粘贴数据来自A1。

返回源wb并重复直到dropdownlist中的最后一个值。我正在使用的代码低于但问题是它只是没有更新B：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

从您的代码中可以明显看出，您尝试了很多东西。一些评论：

最好避免使用“激活”和“选择”。相反，定义明确要使用的对象。在下面的代码中，我定义了一个SourceWB（源工作簿），一个DestWB（目标工作簿），一个SourceSht（在SourceWB中包含所需信息的工作表）和一个DestSht（存储信息的DestWB中的工作表）。在＆＃34;初始＆＃34;代码的一部分，你需要相应地更改名称 - 我使用的名称适合我以前测试的小问题。
您试图强制更改SourceSht中B3的值。在下面的代码中，我找到了用于B3的验证列表的范围，并直接使用该范围内的数据，而不是这种方法。
在您的代码中，您假设工作表名称（在验证列表范围中定义）存在。我正在检查它是否存在，如果不存在则创建工作表。
您可能需要考虑其他一些操作：在将值粘贴到目标表之前清除目标表中的数据;在例行程序开头设置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

更新 - 基于未使用命名范围进行验证

如果使用命名范围或范围引用来验证Cell 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

excel vb下拉列表更新

1 个答案: