Is there any way to fix this loop in VBA Excel? - excel

Question

I have few sheets in my Excel. I want this code to apply Some specific Sheet. Since I am not good at vba I am unable to do it. Please somebody help me. How do I add Sheet3 to 17 to this code so that code only run for these sheets.
Sub insertRowsSheets()
' Disable Excel properties before macro runs
With Application
.Calculation = xlCalculationManual
.EnableEvents = False
.ScreenUpdating = False
End With
' Declare object variables
Dim ws As Worksheet, iCountRows As Integer
Dim activeSheet As Worksheet, activeRow As Long
Dim startSheet As String
' State activeRow
activeRow = ActiveCell.Row
' Save initial active sheet selection
startSheet = ThisWorkbook.activeSheet.Name
' Trigger input message to appear - in terms of how many rows to insert
iCountRows = Application.InputBox(Prompt:="How many rows do you want to insert, starting with row " _
& activeRow & "?", Type:=1)
' Error handling - end the macro if a zero, negative integer or non-integer value is entered
If iCountRows = False Or iCountRows <= 0 Then End
' Loop through the worksheets in active workbook
For Each ws In ActiveWorkbook.Sheets
ws.Activate
Rows(activeRow & ":" & activeRow + iCountRows - 1).Insert
Range("A9").Select
Range("A8:C8").Select
Selection.Copy
Range("A9").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Range("D8:J8").Select
Selection.AutoFill Destination:=Range("D8:J9")
Range("D8:J9").Select
Range("K8:L8").Select
Selection.Copy
Range("K9").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Range("M8:T8").Select
Selection.AutoFill Destination:=Range("M8:T9")
Range("M8:T9").Select
Range("A8").Select
Next ws
' Move cursor back to intial worksheet
Worksheets(startSheet).Select
Range("A8").Select
' Re-enable Excel properties once macro is complete
With Application
.Calculation = xlCalculationAutomatic
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub

Answer 1

Update Worksheets
This should work the same way as before.
At least it should help you to figure out how to loop through an array of worksheet names instead of the worksheets collection.
I could not figure out the logic of copying and filling. Shouldn't you be filling as many rows as the user selected starting from the active row?
The Code
Option Explicit
Sub insertRowsSheets()
' Define Worksheet Names Array.
Dim wsNames As Variant ' Tab names, not code names.
wsNames = Array("Sheet3", "Sheet4", "Sheet5", "Sheet6", "Sheet7", _
"Sheet8", "Sheet9", "Sheet10", "Sheet11", "Sheet12", _
"Sheet13", "Sheet14", "Sheet15", "Sheet16", "Sheet17")
' Declare object variables
Dim wb As Workbook
Dim ws As Worksheet
Dim RowsCount As Long
Dim ActiveRow As Long
Dim StartSheet As String
Dim i As Long
' Define workbook.
Set wb = ThisWorkbook ' The workbook containing this code.
' State activeRow
ActiveRow = ActiveCell.Row
' Trigger input message to appear - in terms of how many rows to insert
RowsCount = Application.InputBox(Prompt:="How many rows do you want to insert, starting with row " _
& ActiveRow & "?", Type:=1)
' Error handling - end the macro if a zero, negative integer or non-integer value is entered
If RowsCount = False Or RowsCount <= 0 Then Exit Sub
' Loop through the worksheets.
For i = LBound(wsNames) To UBound(wsNames)
With wb.Worksheets(wsNames(i))
.Rows(ActiveRow & ":" & ActiveRow + RowsCount - 1).Insert
.Range("A9:C9").Value = .Range("A8:C8").Value
.Range("D8:J8").AutoFill Destination:=.Range("D8:J9")
.Range("K9:L9").Value = .Range("K8:L8").Value
.Range("M8:T8").AutoFill Destination:=.Range("M8:T9")
End With
Next i
End Sub

Answer 2

' Loop through the worksheets in active workbook
For i = 3 To 17 Step 1 'This runs from the 3rd Sheet to the 17th irrespective of the name. Use array method if the sheets are mixed up
If WorksheetIDExists(i, ActiveWorkbook) Then
Set ws = ActiveWorkbook.Worksheets(i)
With ws
.Rows(activeRow & ":" & activeRow + iCountRows - 1).Insert '<- Kindly note that, if the active row is above A8, the whole script becomes a mess
.Range("A8:C8").Copy
.Range("A9").PasteSpecial Paste:=xlPasteValues
.Range("D8:J9").FillDown
.Range("K8:L8").Copy
.Range("K9").PasteSpecial Paste:=xlPasteValues
.Range("M8:T8").FillDown
.Range("A8").Select
End With
End If
Next i
Add this Function as well.
Function WorksheetIDExists(shtid As Integer, wb As Workbook) As Boolean
Dim sht As Worksheet
On Error Resume Next
Set sht = wb.Worksheets(shtid)
On Error GoTo 0
WorksheetIDExists = Not sht Is Nothing
End Function