Question

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

对于我需要的每个副本：

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

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

3.仅复制值（无公式）

将工作表重命名为下拉列表的值。
将所有复制的工作表保存到1个工作簿中

按下按钮时调用的代码（如下所示）当前根据sheet2 rowA（按预期）保存工作表X次。

缺少步骤1,2,4和5

我现在的代码（按下按钮点击）

Dim x As Integer    '~~>Loop counter
Dim WS As Worksheet
Dim LastCellA As Range, LastCellB As Range
Dim LastCellRowNumber As Long

Set WS = Worksheets("Sheet2")    '~~>Sheet with names
With WS
    Set LastCellA = .Cells(.Rows.Count, "A").End(xlUp)    '~~>Column with names.
    '~~>This needs to be changed to find the range as data may not start at A1

    x = Application.WorksheetFunction.Max(LastCellA.Row)
End With



For numtimes = 1 To x
    ActiveWorkbook.Sheets("Sheet1").Copy _
            After:=ActiveWorkbook.Sheets(Worksheets.Count)
    '~~>Copy values only
    ActiveSheet.UsedRange.Value = ActiveSheet.UsedRange.Value
Next

Answer 1

根据您提供的代码，我相信这就是您所寻找的。

它将遍历您的列表，将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

Answer 2

仍然......我不确定你＆＃34;导入＆＃34;基于下拉列表的不同值。这可能是用于编码数据的不同宏。然后，您需要调用该宏而不是.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

修改：

如果您在使用Sheet2列A列表时遇到问题（因为它包含公式的空单元格），您可以尝试不同的方法：

Sub test() Dim wb As Workbook, ws As Worksheet Dim xVal As Variant With ThisWorkbook Set ws = .Sheets("Sheet2") Set wb = Workbooks.Add For Each xVal In Intersect(ws.Range("A:A"), ws.UsedRange).Value If Len(xVal) Then .Sheets("Sheet1").Range("M1").Value = xVal Calculate .RefreshAll .Sheets("Sheet1").Copy , wb.Sheets(wb.Sheets.Count) wb.Sheets(wb.Sheets.Count).Name = ws.Cells(i, 1).Value wb.Sheets(wb.Sheets.Count).UsedRange.Value = wb.Sheets(wb.Sheets.Count).UsedRange.Value End If Next Application.DisplayAlerts = False wb.Sheets(1).Delete Application.DisplayAlerts = True End With End Sub

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

2 个答案: