Updating macro to loop through all worksheets and execute

Question

I have a macro that current works as-is but I wanted to use a counter to loop through each worksheet and execute the macro vs. using the Activate command b/c my macro references the ActiveSheet.

I've tried to change this several times but end up with issues each time not incrementing to the next sheet. Any help would be appreciated.

Sub Set_Data()

Dim lngCount As Long
Dim nLastCol, i, j As Integer

'Capture Required Inputs
sTerm = InputBox("Enter Term ID")
sProduct = InputBox("Enter Product ID")
sState = InputBox("Enter 2-Letter State Abbreviation")

For j = 1 To ActiveWorkbook.Worksheets.Count
Set ws = Worksheets(j)
ws.Activate

'DO NOT RUN IF ALREADY RUN
If ActiveSheet.Range("A1") <> "Issue Age" Then
   MsgBox "This Workbook Has Already Been Updated"
Exit Sub
End If

lngCount = Application.WorksheetFunction.CountA(Columns(2))
'Rename Issue Age Column Header

Range("A1").Select
ActiveCell.FormulaR1C1 = "Age"

'Insert Term Column
Columns("A:A").Insert Shift:=xlToRight
Range("A1:A" & lngCount).FormulaR1C1 = sTerm

Range("A1").Select
ActiveCell.FormulaR1C1 = "termid"

'Insert  Product Column
Columns("A:A").Insert Shift:=xlToRight
Range("A1:A" & lngCount).FormulaR1C1 = sProduct

    Range("A1").Select
    ActiveCell.FormulaR1C1 = "productid"


    'Insert  State Column
    Columns("A:A").Insert Shift:=xlToRight
Range("A1:A" & lngCount).FormulaR1C1 = sState
Range("A1").Select
ActiveCell.FormulaR1C1 = "State"


'Delete Issue Age Column

'This next variable will get the column number of the very last column that has data in it, so we can use it in a loop later
nLastCol = ActiveSheet.Cells.Find("*", LookIn:=xlValues, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column

'This loop will go through each column header and delete the column if the header contains "Issue Age"

For i = nLastCol To 1 Step -1
    If InStr(1, ActiveSheet.Cells(1, i).Value, "Issue Age", vbTextCompare) > 0 Then
        ActiveSheet.Columns(i).Delete Shift:=xlShiftToLeft
    End If
Next i

'Delete Empty Column

i = ActiveSheet.Cells.SpecialCells(xlLastCell).Column
Do Until i = 0

If WorksheetFunction.CountA(Columns(i)) = 0 Then
Columns(i).Delete
End If

i = i - 1

Loop

'Rename Tabs
If InStr((ActiveSheet.Name), ("25,000")) Then
    ActiveSheet.Name = "A25"
End If
If InStr((ActiveSheet.Name), ("100,000")) Then
    ActiveSheet.Name = "A100"
End If

If InStr((ActiveSheet.Name), ("250,000")) Then
    ActiveSheet.Name = "A250"
End If
If InStr((ActiveSheet.Name), ("500,000")) Then
    ActiveSheet.Name = "A500"
End If

Next j

End Sub

score 0 · Answer 1 · answered Aug 26 '17 at 14:07

Try this out, havent tested it.

Sub Set_Data()
Dim ws As Worksheet
Dim lngCount As Long
Dim nLastCol, i, j As Integer

'Capture Required Inputs
sTerm = InputBox("Enter Term ID")
sProduct = InputBox("Enter Product ID")
sState = InputBox("Enter 2-Letter State Abbreviation")

For Each ws In Worksheets
With ws
'DO NOT RUN IF ALREADY RUN
If .Range("A1").Value <> "Issue Age" Then
   MsgBox "This Workbook Has Already Been Updated"
Exit Sub
End If

lngCount = Application.WorksheetFunction.CountA(.Columns(2))
'Rename Issue Age Column Header

.Range("A1").Value = "Age"

'Insert Term Column
.Columns("A:A").Insert Shift:=xlToRight
.Range("A1:A" & lngCount).Value = sTerm

.Range("A1").Value = "termid"

'Insert  Product Column
.Columns("A:A").Insert Shift:=xlToRight
.Range("A1:A" & lngCount).Value = sProduct

    .Range("A1").Value = "productid"


    'Insert  State Column
    .Columns("A:A").Insert Shift:=xlToRight
.Range("A1:A" & lngCount).Value = sState
.Range("A1").Value = "State"


'Delete Issue Age Column

'This next variable will get the column number of the very last column that has data in it, so we can use it in a loop later
nLastCol = .Cells.Find("*", LookIn:=xlValues, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column

'This loop will go through each column header and delete the column if the header contains "Issue Age"

For i = nLastCol To 1 Step -1
    If InStr(1, .Cells(1, i).Value, "Issue Age", vbTextCompare) > 0 Then
        .Columns(i).Delete Shift:=xlShiftToLeft
    End If
Next i

'Delete Empty Column

i = .Cells.SpecialCells(xlLastCell).Column
Do Until i = 0

If WorksheetFunction.CountA(.Columns(i)) = 0 Then
.Columns(i).Delete
End If

i = i - 1

Loop
'Rename Tabs
If InStr((.Name), ("25,000")) Then
    .Name = "A25"
End If
If InStr((.Name), ("100,000")) Then
    .Name = "A100"
End If

If InStr((.Name), ("250,000")) Then
    .Name = "A250"
End If
If InStr((.Name), ("500,000")) Then
    .Name = "A500"
End If

End With
Next ws

End Sub

As you said, try avoiding .Select, this might help you aswell. If you want to change the content of a cell and not insert an actual formular use .Value.

Updating macro to loop through all worksheets and execute

1 Answers1