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

Question

I have a list of ID#s in column A on Sheet 2 (starting at cell A2).

I am trying to create a macro to loops through each ID #, copies it into cell A9 on Sheet 1 and then copies Sheet 3 into a new workbook.

For each ID#, Sheet 3 should be copied into that same new workbook under a different worksheet/tab.

I am not a coder so all I have is what I can find on Google and I can't seem to get everything in order. Any and all help is greatly appreciated.

This is what I have so far.. what i cant figure out is how to end the loop at blank cell, how to get the macro to revert back to the source after copying worksheet to new workbook, and then how to add the subsequent loops to that now existing workbook.

    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

There isn't much of your code left apart from ScreenUpdating, For and Next. I've commented some steps where it may not be obvious why they are being done. There's some additional comments about things you may not be familiar with.

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

All variables are declared - you can and should set your VBA editor to "Require Variable Declaration" (under Tools -> Options). This will insert "Option Explicit" at the top of every new module.

There are no "Select" or "Activate" commands. You can usually avoid them by using With...EndWith structures or fully qualifying objects.

Square bracket range references - [A2] is the same as Range("A2").

Any questions, post a comment.