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.