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

2 回答

• 2

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

  EDIT ：

  如果您在使用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
  

  回复于 2024-04-27T23:09:34+08:00
• 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
  

  回复于 2024-04-27T23:09:34+08:00