更新宏循環遍歷所有工作表並執行

Question

我有一個當前按原樣工作的宏，但我想使用計數器循環遍歷每個工作表並執行宏與使用激活命令b/c我的宏引用ActiveSheet。

我試圖改變這幾次，但最終的問題，每次不遞增到下一張表。任何幫助，將不勝感激。

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 

正如你所說的，儘量避免.Select，this可以幫助你以及。如果您想更改單元格的內容並且不插入實際的表單使用.Value。