Vba 更新宏以循环所有工作表并执行

我有一个宏，当前可以按原样工作，但我想使用计数器在每个工作表中循环并执行宏，而不是使用激活命令b/c我的宏引用活动表

我已经尝试过几次改变这一点，但每次都会出现问题，而不是增加到下一页。任何帮助都将不胜感激

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

subset_Data（）
暗计数等于长
Dim nLastCol，i，j为整数
“捕获所需的输入
sTerm=输入框（“输入术语ID”）
sProduct=输入框（“输入产品ID”）
sState=InputBox（“输入两个字母的州缩写”）
对于j=1到ActiveWorkbook.Worksheets.Count
设置ws=工作表（j）
ws.Activate
'如果已运行，则不运行
如果ActiveSheet.Range（“A1”）“发行期限”，则
MsgBox“此工作簿已更新”
出口接头
如果结束
lngCount=Application.WorksheetFunction.CountA（第（2）列）
'重命名问题期限列标题
范围（“A1”）。选择
ActiveCell.FormulaR1C1=“年龄”
'插入术语列
列（“A:A”）。插入移位：=xlToRight
范围（“A1:A”和lngCount）。公式1c1=sTerm
范围（“A1”）。选择
ActiveCell.FormulaR1C1=“termid”
'插入产品栏
列（“A:A”）。插入移位：=xlToRight
范围（“A1:A”和lngCount）。公式1c1=s产品
范围（“A1”）。选择
ActiveCell.FormulaR1C1=“产品ID”
'插入状态列
列（“A:A”）。插入移位：=xlToRight
范围（“A1:A”和lngCount）。公式1C1=S状态
范围（“A1”）。选择
ActiveCell.FormulaR1C1=“状态”
'删除问题年龄列
'下一个变量将获取包含数据的最后一列的列号，因此我们可以在以后的循环中使用它
nLastCol=ActiveSheet.Cells.Find（“*”，LookIn:=xlValues，SearchOrder:=xlByColumns，SearchDirection:=xlPrevious.Column
'此循环将遍历每个列标题，如果标题包含“问题期限”，则删除该列
对于i=nLastCol至1步骤-1
如果InStr（1，ActiveSheet.Cells（1，i）.Value，“发行期限”，vbTextCompare）>0，则
ActiveSheet.Columns（i）.删除移位：=xlshiftotoleft
如果结束
接下来我
'删除空列
i=ActiveSheet.Cells.SpecialCells（xlLastCell.Column）
直到i=0为止
如果工作表function.CountA（列（i））=0，则
第（i）栏。删除
如果结束
i=i-1
环
'重命名选项卡
如果InStr（（ActiveSheet.Name），（“25000”）），则
ActiveSheet.Name=“A25”
如果结束
如果InStr（（ActiveSheet.Name），（“100000”）），则
ActiveSheet.Name=“A100”
如果结束
如果InStr（（ActiveSheet.Name），（“250000”）），则
ActiveSheet.Name=“A250”
如果结束
如果InStr（（ActiveSheet.Name），（“500000”）），则
ActiveSheet.Name=“A500”
如果结束
下一个j
端接头

试试看，还没有测试过

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

subset_Data（）
将ws设置为工作表
暗计数等于长
Dim nLastCol，i，j为整数
“捕获所需的输入
sTerm=输入框（“输入术语ID”）
sProduct=输入框（“输入产品ID”）
sState=InputBox（“输入两个字母的州缩写”）
对于工作表中的每个ws
与ws
'如果已运行，则不运行
如果.Range（“A1”）.值为“发行年龄”，则
MsgBox“此工作簿已更新”
出口接头
如果结束
lngCount=Application.WorksheetFunction.CountA（.Columns（2））
'重命名问题期限列标题
.Range（“A1”）.Value=“年龄”
'插入术语列
.列（“A:A”）。插入移位：=xlToRight
.Range（“A1:A”和lngCount）。值=sTerm
.Range（“A1”）.Value=“termid”
'插入产品栏
.列（“A:A”）。插入移位：=xlToRight
.Range（“A1:A”和lngCount）。值=产品
.Range（“A1”）.Value=“productid”
'插入状态列
.列（“A:A”）。插入移位：=xlToRight
.范围（“A1:A”和lngCount）。值=sState
.Range（“A1”）.Value=“State”
'删除问题年龄列
'下一个变量将获取包含数据的最后一列的列号，因此我们可以在以后的循环中使用它
nLastCol=.Cells.Find（“*”，LookIn:=xlValues，SearchOrder:=xlByColumns，SearchDirection:=xlPrevious）.Column
'此循环将遍历每个列标题，如果标题包含“问题期限”，则删除该列
对于i=nLastCol至1步骤-1
如果InStr（1，.Cells（1，i）.Value，“发布时间”，vbTextCompare）>0，则
.列（i）.删除移位：=xlShiftToLeft
如果结束
接下来我
'删除空列
i=.Cells.SpecialCells（xlLastCell）.Column
直到i=0为止
如果工作表function.CountA（.Columns（i））=0，则
.第（i）栏。删除
如果结束
i=i-1
环
'重命名选项卡
如果仪表（（.名称），（“25000”）），则
.Name=“A25”
如果结束
如果仪表（（.名称），（“100000”），则
.Name=“A100”
如果结束
如果仪表（（.名称），（“250000”）），则
.Name=“A250”
如果结束
如果仪表（（.名称），（“500000”）则
.Name=“A500”
如果结束
以
下一个ws
端接头

---

正如您所说，尽量避免使用

。选择
，也可能会对您有所帮助。如果要更改单元格内容而不插入实际公式，请使用
.Value
 试试这个，我还没有测试过

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

subset_Data（）
将ws设置为工作表
暗计数等于长
Dim nLastCol，i，j为整数
“捕获所需的输入
sTerm=输入框（“输入术语ID”）
sProduct=输入框（“输入产品ID”）
sState=InputBox（“输入两个字母的州缩写”）
对于工作表中的每个ws
与ws
'如果已运行，则不运行
如果.Range（“A1”）.值为“发行年龄”，则
MsgBox“此工作簿已更新”
出口接头
如果结束
lngCount=Application.WorksheetFunction.CountA（.Columns（2））
'重命名问题期限列标题
.Range（“A1”）.Value=“年龄”
'插入术语列
.列（“A:A”）。插入移位：=xlToRight
.Range（“A1:A”和lngCount）。值=sTerm
.Range（“A1”）.Value=“termid”
'插入产品栏
.列（“A:A”）。插入移位：=xlToRight
.Range（“A1:A”和lngCount）。值=产品
.Range（“A1”）.Value=“productid”
'插入状态列
.列（“A:A”）。插入移位：=xlToRight
.范围（“A1:A”和lngCount）。值=sState
.Range（“A1”）.Value=“State”
'删除问题年龄列
'下一个变量将获取包含数据的最后一列的列号，因此我们可以在以后的循环中使用它
nLastCol=.Cells.Find（“*”，LookIn:=xlValues，SearchOrder:=xlByColumns，SearchDirection:=xlPr