マクロを更新してすべてのワークシートをループして実行する

Question

現在のマクロはそのまま使用していますが、各ワークシートをループしてマクロを実行したいのですが、アクティブシート。

私はこれを何回か変更しようとしましたが、次のシートに増分しないたびに問題になります。どんな助けもありがとう。

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 

Answer 1

これを試してみてください。

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 

あなたが言ったように、aswellあなたを助けるかもしれない.Select、thisを回避してみてください。セルの内容を変更し、実際の定型文を挿入しない場合は、.Valueを使用します。