Excel VBA循环直到空白单元格并将工作表复制到新工作簿

Question

我在工作表 2 的 A 列中有一个 ID# 列表（从单元格 A2 开始）。

我正在尝试创建一个宏来循环遍历每个 ID #，将其复制到工作表 1 上的单元格 A9 中，然后将工作表 3 复制到新工作簿中。

对于每个 ID#，应将工作表 3 复制到不同工作表/选项卡下的同一新工作簿中。

我不是编码员，所以我只有在 Google 上可以找到的所有内容，而且我似乎无法将所有内容整理好。非常感谢任何和所有帮助。

这是我到目前为止所拥有的.. 我想不通的是如何在空白单元格处结束循环，如何在将工作表复制到新工作簿后让宏恢复到源，然后如何添加随后循环到该现有工作簿。

    Sub Test1()
  Dim x As Integer
  Application.ScreenUpdating = False
  ' Set numrows = number of rows of data.
  NumRows = Range("a2", Range("a2").End(xlDown)).Rows.Count
  ' Select cell a2.
  Range("a2").Select
  ' Establish "For" loop to loop "numrows" number of times.
  For x = 1 To NumRows
     Sheets("Sheet 1").Range("A9").Value = ActiveCell
      Sheets("Sheet 3").Copy
     ' Selects cell down 1 row from active cell.
     ActiveCell.Offset(1, 0).Select
  Next
  Application.ScreenUpdating = True

结束子

Answer 1

除了 ScreenUpdating、For 和 Next 之外，您的代码已不多。我已经评论了一些步骤，其中可能不清楚为什么要完成它们。还有一些关于您可能不熟悉的内容的额外信息。

Sub CopySheetsToNewWB()
Dim ID_cell As Range 'will be used to control loop flow
Dim SourceWB As Workbook
Dim DestWB As Workbook
Dim ControlSheet As Worksheet 'sheet with ID#s
Dim IDsToCopy As Range
Dim SheetToCopy As Worksheet
Dim PathSeparator As String
Dim SaveName As String

    Application.ScreenUpdating = False
    Set SourceWB = ThisWorkbook
    'test if file saved on device/network or cloud and set separator
    'because new file will be saved in same location
    If InStr(1, SourceWB.Path, "\") > 0 Then
        PathSeparator = "\"
    Else
        PathSeparator = "/"
    End If
    Set ControlSheet = SourceWB.Sheets("Sheet2")
    Set SheetToCopy = SourceWB.Sheets("Sheet3")
    With ControlSheet
        Set IDsToCopy = Range(.[A2], .[A2].End(xlDown))
    End With
    For Each ID_cell In IDsToCopy
        'As ID_Cell is based on an IFERROR(...,"") formula, test if blank.
        If ID_cell <> "" Then
            With SourceWB 'allows subsequent commands without having to specify it
                .Sheets("Sheet1").[A9] = ID_cell.Value2
                'Test if DestWB already exists
                If Not DestWB Is Nothing Then
                    'it's not nothing so it must be something (i.e. it exists)
                    SheetToCopy.Copy after:=DestWB.Sheets(DestWB.Sheets.Count)
                Else
                    'create DestWB and save it in the same location as SourceWB
                    'using SourceWB name with date appended and SourceWB file extension.
                    'INSTR is similar to FIND in Excel but doesn't error if search
                    'string is not found - just returns 0.  INSTRREV finds position of
                    'the last instance of searched string (in case of "."s in filename).
                    SaveName = .Path & PathSeparator & Left(.Name, InStr(1, .Name, ".") - 1) _
                    & " as at " & _
                    Format(Date, "yyyymmdd") & _
                    Right(.Name, Len(.Name) - InStrRev(.Name, ".") + 1)
                    SheetToCopy.Copy
                    ActiveWorkbook.SaveAs Filename:=SaveName, FileFormat:=SourceWB.FileFormat
                    Set DestWB = ActiveWorkbook
                End If
            End With
            'Copied sheet may have formulas linking to SourceWB so change to values
            'and as it's still named "Sheet3", rename it after ID#
            With DestWB.Sheets("Sheet3")
                .UsedRange.Copy
                .[A1].PasteSpecial xlPasteValues
                .Name = ID_cell.Value2
            End With
        End If
    Next
    DestWB.Save
  Application.ScreenUpdating = True
End Sub

所有变量都已声明 - 您可以并且应该将 VBA 编辑器设置为“需要变量声明”（在工具 -> 选项下）。这将在每个新模块的顶部插入“Option Explicit”。

没有“选择”或“激活”命令。您通常可以通过使用 With...EndWith 结构或完全限定的对象来避免它们。

方括号范围引用 - [A2] 与 Range("A2") 相同。

有任何问题，发表评论。