Excel VBA-将工作表复制到新工作簿X次

我需要将同一工作表复制X次（X=sheet2 A行）到新工作簿中

对于每个副本，我需要：

1.更改下拉列表以显示下一个值

2.刷新（工作簿连接到数据库，该数据库根据下拉列表的值提取不同的信息，不会自动刷新）

3.仅复制值（无公式）

将图纸重命名为下拉列表的值

将所有复制的工作表保存到一个工作簿中

按下按钮时调用的“我的代码”（见下文）当前会根据sheet2 rowA（按预期）将纸张保存X次

它缺少步骤1、2、4和5

我目前拥有的代码（点击按钮时调用）

---

根据你提供的代码，我相信这就是你要寻找的

它将循环浏览您的列表，将sheet1复制到新工作簿并命名该工作表

我不知道你想要什么通过你的下拉列表循环

Sub Button1_Click()
    Dim wb As Workbook, Bk As Workbook
    Dim WS As Worksheet, sh As Worksheet
    Dim LastCellA As Long, LastCellB As Range, c As Range
    Dim LastCellRowNumber As Long
    Dim x As Integer    '~~>Loop counter

    Set wb = ThisWorkbook
    Set WS = wb.Worksheets("Sheet2")    '~~>Sheet with names
    Set sh = wb.Sheets("Sheet1")

    With WS
        LastCellA = .Cells(.Rows.Count, "A").End(xlUp).Row  '~~>Column with names.
        '~~>This needs to be changed to find the range as data may not start at A1
        Set LastCellB = .Range("A1:A" & LastCellA).SpecialCells(xlCellTypeConstants, 23)
    End With

    Set Bk = Workbooks.Add

    For Each c In LastCellB.Cells
        sh.Range("M1") = c
        sh.Copy After:=Bk.Sheets(Worksheets.Count)
        With ActiveSheet
            '~~>Copy values only
            .UsedRange.Value = .UsedRange.Value
            .Name = c
        End With
    Next c

End Sub

---

根据你提供的代码，我相信这就是你要寻找的

它将循环浏览您的列表，将sheet1复制到新工作簿并命名该工作表

我不知道你想要什么通过你的下拉列表循环

Sub Button1_Click()
    Dim wb As Workbook, Bk As Workbook
    Dim WS As Worksheet, sh As Worksheet
    Dim LastCellA As Long, LastCellB As Range, c As Range
    Dim LastCellRowNumber As Long
    Dim x As Integer    '~~>Loop counter

    Set wb = ThisWorkbook
    Set WS = wb.Worksheets("Sheet2")    '~~>Sheet with names
    Set sh = wb.Sheets("Sheet1")

    With WS
        LastCellA = .Cells(.Rows.Count, "A").End(xlUp).Row  '~~>Column with names.
        '~~>This needs to be changed to find the range as data may not start at A1
        Set LastCellB = .Range("A1:A" & LastCellA).SpecialCells(xlCellTypeConstants, 23)
    End With

    Set Bk = Workbooks.Add

    For Each c In LastCellB.Cells
        sh.Range("M1") = c
        sh.Copy After:=Bk.Sheets(Worksheets.Count)
        With ActiveSheet
            '~~>Copy values only
            .UsedRange.Value = .UsedRange.Value
            .Name = c
        End With
    Next c

End Sub

---

还是。。。我不确定根据下拉列表“导入”不同值的意义。这可能是用于存放数据的不同宏。然后需要调用该宏，而不是

.RefreshAll

Sub test()

  Dim uRow As Long, lRow As Long, i As Long
  Dim wb As Workbook, ws As Object

  With ThisWorkbook
    Set ws = .Sheets("Sheet2")
    With ws
      uRow = .Cells(.Rows.Count, "A").End(xlUp).End(xlUp).Row
      lRow = .Cells(.Rows.Count, "A").End(xlUp).Row
    End With

    Set wb = Workbooks.Add

    For i = uRow To lRow

      .Sheets("Sheet1").Range("M1").Value = ws.Cells(i, 1).Value '<~~~ this should change the dropdown
      Calculate
      .RefreshAll
      .Sheets("Sheet1").Copy , wb.Sheets(wb.Sheets.Count)
      wb.Sheets(wb.Sheets.Count).Name = ws.Cells(i, 1).Value
    Next

    Application.DisplayAlerts = False
    wb.Sheets(1).Delete
    Application.DisplayAlerts = True

    For Each ws In wb.Sheets
      ws.UsedRange.Value = ws.UsedRange.Value
    Next

  End With    
End Sub

---

还是。。。我不确定根据下拉列表“导入”不同值的意义。这可能是用于存放数据的不同宏。然后需要调用该宏，而不是

.RefreshAll

Sub test()

  Dim uRow As Long, lRow As Long, i As Long
  Dim wb As Workbook, ws As Object

  With ThisWorkbook
    Set ws = .Sheets("Sheet2")
    With ws
      uRow = .Cells(.Rows.Count, "A").End(xlUp).End(xlUp).Row
      lRow = .Cells(.Rows.Count, "A").End(xlUp).Row
    End With

    Set wb = Workbooks.Add

    For i = uRow To lRow

      .Sheets("Sheet1").Range("M1").Value = ws.Cells(i, 1).Value '<~~~ this should change the dropdown
      Calculate
      .RefreshAll
      .Sheets("Sheet1").Copy , wb.Sheets(wb.Sheets.Count)
      wb.Sheets(wb.Sheets.Count).Name = ws.Cells(i, 1).Value
    Next

    Application.DisplayAlerts = False
    wb.Sheets(1).Delete
    Application.DisplayAlerts = True

    For Each ws In wb.Sheets
      ws.UsedRange.Value = ws.UsedRange.Value
    Next

  End With    
End Sub

---

---

引号：“1.更改下拉列表以显示下一个值”下拉列表的含义是什么？数据验证？工作表中的活动X组合框？用户表单中的组合框？对于第2点：难道你不能运行一个

RefreshAll

？@DirkReichel表单将根据下拉列表中的值填充数据。下拉列表将查找同一工作簿上另一张工作表上的值。啊，我不知道refreshAll，我对VB（A）@DirkReichel是全新的，这是一个查找下拉列表。不确定它们在excel中的名称。通过数据选项卡->数据验证->允许进行：list@DirkReichelSheet1（要复制的工作表）不确定是哪个单元格，将其称为m1（我可以稍后更改）引号：“1.更改下拉列表以显示下一个值”下拉列表的含义是什么？数据验证？工作表中的活动X组合框？用户表单中的组合框？对于第2点：难道你不能运行一个

RefreshAll

？@DirkReichel表单将根据下拉列表中的值填充数据。下拉列表将查找同一工作簿上另一张工作表上的值。啊，我不知道refreshAll，我对VB（A）@DirkReichel是全新的，这是一个查找下拉列表。不确定它们在excel中的名称。通过数据选项卡->数据验证->允许进行：list@DirkReichelSheet1（要复制的工作表）不确定是哪个单元格，将其命名为m1（我可以稍后更改）效果很好。下拉列表类型为数据验证，确定每次刷新工作表时放入表1的值（从其他工作表和数据库中提取的值）。重新输入的值与下拉列表中的值有偏差。我注意到，如果列表中包含公式，我们都可能会遇到麻烦。。。然而，现在看来，情况并非如此…@DirkReichel我的练习表上有简单的公式，看起来不错。有什么可能的问题？如果公式只返回一个空字符串，如

=”

，它（技术上）不是空的。。。但这是Sheet2列代码的一部分。。。我会试着用一种简单的方法来修复它……效果很好。下拉列表类型为数据验证，确定每次刷新工作表时放入表1的值（从其他工作表和数据库中提取的值）。重新输入的值与下拉列表中的值有偏差。我注意到，如果列表中包含公式，我们都可能会遇到麻烦。。。然而，现在看来，情况并非如此…@DirkReichel我的练习表上有简单的公式，看起来不错。有什么可能的问题？如果公式只返回一个空字符串，如

=”

，它（技术上）不是空的。。。但这是Sheet2列代码的一部分。。。我会尝试用一种简单的方式修复它…在结尾处缺少endwith。工作正常，但不会更改“数据验证”下拉列表。有没有办法将下拉列表与工作表名称匹配？丢失了

结尾处的某个地方。。。很抱歉但它会改变你的下拉列表。只需检查是否在正确的页PLS上执行此操作下拉列表应位于M1中的页1上是否正确？如果是这样的话，我的endok就不起作用了。。。我的代码告诉我在sheet2做这件事。。。我会改变（你也需要这样做）；请在结尾处使用endwith。工作正常，但不会更改“数据验证”下拉列表。有没有办法将下拉列表与工作表名称匹配？丢失了
结尾处的某个地方。。。很抱歉但它会改变你的下拉列表。只需检查是否在正确的页PLS上执行此操作下拉列表应位于M1中的页1上是否正确？如果是这样的话，我的endok就不起作用了。。。我的代码告诉我在sheet2做这件事。。。我会改变（你也需要这样做）；P