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
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.
The technical post webpages of this site follow the CC BY-SA 4.0 protocol. If you need to reprint, please indicate the site URL or the original address.Any question please contact:yoyou2525@163.com.