Excel Macro Loop Through Range - excel

Question

I am using the macro below by clicking a button each time I want to run it. This works ok but is quite time consuming.
In the Summary sheet (range H2:H21) of the workbook I have a list of ID numbers which I have been manually pasting into E3 before running the macro.
Instead of doing this I would like to amend the macro so it loops through all the IDs when I click the button.
The workbook is quite big and takes a while to calculate each time a new ID is pasted in so this needs to be factored in.
Can anyone show me have to do these things?
Sub CreateNewSheet()
Application.ScreenUpdating = False
Application.Calculation = xlManual
With Workbooks("Batsmen.xlsx").Worksheets.Add()
.Name = ThisWorkbook.Worksheets("Summary").Range("E3").Value
End With
With ThisWorkbook.Worksheets("Summary").Range("A22:J63").Copy
Workbooks("Batsmen.xlsx").Sheets(1).Range("A1").PasteSpecial Paste:=xlPasteValues
Workbooks("Batsmen.xlsx").Sheets(1).Range("A1").PasteSpecial Paste:=xlPasteFormats
Workbooks("Batsmen.xlsx").Sheets(1).Range("A1").PasteSpecial Paste:=xlPasteColumnWidths
Workbooks("Batsmen.xlsx").Sheets(1).Range("A:J").Font.Size = 10
End With
With ThisWorkbook.Worksheets("Summary").Range("A22:J27").Copy
With Workbooks("Batsmen.xlsx").Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Offset(2)
.PasteSpecial Paste:=xlPasteValues
.PasteSpecial Paste:=xlPasteFormats
.PasteSpecial Paste:=xlPasteColumnWidths
.Font.Size = 10
End With
End With
Application.Calculation = xlAutomatic
Application.ScreenUpdating = True
End Sub

Answer 1

This can be optimized, but should get you started.
Check the code's comments and adjust it to fit your needs.
You can put the cursos inside the Process procedure, press F8 key and see what the code does.
EDIT: Added summarySheet.Range("E3").value = cell.value to the loop
Option Explicit
Public Sub Process()
Dim targetWorkbook As Workbook
Dim summarySheet As Worksheet
Dim sourceRange As Range
Dim cell As Range
' Customize this settings
Set targetWorkbook = Workbooks("Batsmen.xlsx")
Set summarySheet = ThisWorkbook.Worksheets("Summary")
Set sourceRange = summarySheet.Range("H2:H21")
Application.ScreenUpdating = False
Application.Calculation = xlManual
' Loop through each cell in source range
For Each cell In sourceRange.Cells
' Validate that cell has a value
If cell.Value <> vbNullString Then
' Fill E3 with cell value from range in column H
summarySheet.Range("E3").value = cell.value
' Execute procedure to create new sheet
CreateNewSheet targetWorkbook, cell.Value, summarySheet
End If
Next cell
Application.Calculation = xlAutomatic
Application.ScreenUpdating = True
End Sub
Private Sub CreateNewSheet(ByVal targetWorkbook As Workbook, ByVal newSheetName As String, ByVal summarySheet As Worksheet)
Dim targetSheet As Worksheet
Set targetSheet = targetWorkbook.Worksheets.Add
targetSheet.Name = newSheetName
summarySheet.Range("A22:J63").Copy
With targetSheet
.Range("A1").PasteSpecial Paste:=xlPasteValues
.Range("A1").PasteSpecial Paste:=xlPasteFormats
.Range("A1").PasteSpecial Paste:=xlPasteColumnWidths
.Range("A:J").Font.Size = 10
End With
summarySheet.Range("A22:J27").Copy
With targetSheet.Range("A" & Rows.Count).End(xlUp).Offset(2)
.PasteSpecial Paste:=xlPasteValues
.PasteSpecial Paste:=xlPasteFormats
.PasteSpecial Paste:=xlPasteColumnWidths
.Font.Size = 10
End With
End Sub
Let me know if it works

Answer 2

The code below should answer your question because it does create the sheets you want.
Sub CreateNewSheet()
Dim Wb As Workbook
Dim WbBat As Workbook
Dim WsSum As Worksheet
Dim NamesRange As Range
Dim i As Integer
Dim TabName As String
With Application
.ScreenUpdating = False
.Calculation = xlManual
End With
Set Wb = ThisWorkbook
Set WbBat = Workbooks("Batsmen.xlsx")
Set WsSum = Wb.Worksheets("Summary")
Set NamesRange = WsSum.Range("H2:H21")
For i = 1 To NamesRange.Cells.Count
TabName = Trim(NamesRange.Cells(i).Value)
If Len(TabName) Then ' skip if name is blank
With WbBat.Worksheets.Add()
.Name = TabName
WsSum.Range("A22:J63").Copy Destination:=.Cells(1, "A")
WsSum.Range("A22:J27").Copy Destination:=.Cells(.Rows.Count, "A").End(xlUp).Offset(2)
.Range("A:J").Columns.AutoFit
.Range("A1:J" & .Cells(.Rows.Count, "A").End(xlUp).Row).Font.Size = 10
End With
End If
Next i
With Application
.Calculation = xlAutomatic
.ScreenUpdating = True
End With
End Sub
Regrettably, it doesn't provide you usable code because it pastes the same data to all sheets. I presume that you have a plan how to vary the data. Unfortunately, I failed to understand such a plan from your question. However, I suspect that you will be able to modify the code to make it useful.