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

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

对于我需要的每个副本：

1.更改下拉菜单以显示下一个值

2.做一个刷新（工作簿连接到一个数据库，根据下拉的值拉动不同的信息，不会自动刷新）

3.只复制数值（没有公式）

4. 将表格重命名为下拉列表的值。

5. 将所有复制的工作表保存到1个工作簿中

我的代码（下图）是在当前button上调用的，它基于sheet2 rowA（按照预期）将表单保存X次。

它缺less步骤1,2,4和5

我现在的代码（点击button）

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

仍然…我不确定您是否根据下拉菜单“导入”不同的值。 这可能是一个不同的数据编码macros。 然后，您需要调用该macros而不是.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 

Answer 2

根据你提供的代码，我相信这是你正在寻找的。

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