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」）相同。

有任何問題，發表評論。