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

Question

我有第2页A列（从单元格A2开始）的ID列表。

我试图创建一个宏来遍历每个ID＃，将它复制到Sheet 1上的单元格A9中，然后将Sheet 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左开，和明年。我已经评论了一些可能不明显的步骤，为什么要这样做。关于您可能不熟悉的事情，还有一些额外的评论。

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]与范围（“A2”）相同。

有任何问题，发表评论。