Question

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

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

对于每个ID＃，应将Sheet 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

End Sub

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编辑器设置为“需要变量声明”（在工具 - ＆gt;选项下）。这将在每个新模块的顶部插入“Option Explicit”。

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

方括号范围参考 - [A2]与范围（“A2”）相同。

有任何问题，发表评论。

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

1 个答案: