excel宏适用于所有工作表

时间:2016-11-30 14:30:05

标签: excel vba excel-vba macros

我有一张有多张床单的Excel。我在一张纸上创建了一个宏,下面是宏代码。如何编辑此代码以在一次运行中应用于工作簿中的所有工作表。谢谢

子记分表() “ '得分表宏 “

ActiveWindow.ScrollColumn = 6
ActiveWindow.ScrollColumn = 5
ActiveWindow.ScrollColumn = 4
ActiveWindow.ScrollColumn = 3
ActiveWindow.ScrollColumn = 2
ActiveWindow.ScrollColumn = 1
Columns("F:F").Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Columns("E:E").Select
Selection.TextToColumns Destination:=Range("E1"), DataType:=xlDelimited, _
    TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
    Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
    :="-", FieldInfo:=Array(Array(1, 1), Array(2, 1)), TrailingMinusNumbers:=True
Columns("I:I").Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Columns("H:H").Select
Selection.TextToColumns Destination:=Range("H1"), DataType:=xlDelimited, _
    TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
    Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
    :="-", FieldInfo:=Array(1, 1), TrailingMinusNumbers:=True
Range("I1").Select
ActiveCell.FormulaR1C1 = "3fga "
With ActiveCell.Characters(Start:=1, Length:=5).Font
    .Name = "Verdana"
    .FontStyle = "Bold"
    .Size = 7.5
    .Strikethrough = False
    .Superscript = False
    .Subscript = False
    .OutlineFont = False
    .Shadow = False
    .Underline = xlUnderlineStyleNone
    .Color = -1
    .TintAndShade = 0
    .ThemeFont = xlThemeFontNone
End With
Columns("L:L").Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Columns("K:K").Select
Selection.TextToColumns Destination:=Range("K1"), DataType:=xlDelimited, _
    TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
    Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
    :="-", FieldInfo:=Array(1, 1), TrailingMinusNumbers:=True
Columns("Y:AB").Select
Selection.Delete Shift:=xlToLeft
Columns("Z:Z").Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Columns("Y:Y").Select
Selection.TextToColumns Destination:=Range("Y1"), DataType:=xlDelimited, _
    TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
    Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
    :="-", FieldInfo:=Array(1, 1), TrailingMinusNumbers:=True
Range("Y1").Select
ActiveCell.FormulaR1C1 = "op_fgm"
With ActiveCell.Characters(Start:=1, Length:=6).Font
    .Name = "Verdana"
    .FontStyle = "Bold"
    .Size = 7.5
    .Strikethrough = False
    .Superscript = False
    .Subscript = False
    .OutlineFont = False
    .Shadow = False
    .Underline = xlUnderlineStyleNone
    .Color = -1
    .TintAndShade = 0
    .ThemeFont = xlThemeFontNone
End With
Range("Z1").Select
ActiveCell.FormulaR1C1 = "op_fga "
With ActiveCell.Characters(Start:=1, Length:=7).Font
    .Name = "Verdana"
    .FontStyle = "Bold"
    .Size = 7.5
    .Strikethrough = False
    .Superscript = False
    .Subscript = False
    .OutlineFont = False
    .Shadow = False
    .Underline = xlUnderlineStyleNone
    .Color = -1
    .TintAndShade = 0
    .ThemeFont = xlThemeFontNone
End With
Columns("AA:AA").Select
Selection.Delete Shift:=xlToLeft
Columns("AB:AB").Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Columns("AA:AA").Select
Selection.TextToColumns Destination:=Range("AA1"), DataType:=xlDelimited, _
    TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
    Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
    :="-", FieldInfo:=Array(1, 1), TrailingMinusNumbers:=True
Range("AA1").Select
ActiveCell.FormulaR1C1 = "op_3fg"
With ActiveCell.Characters(Start:=1, Length:=6).Font
    .Name = "Verdana"
    .FontStyle = "Bold"
    .Size = 7.5
    .Strikethrough = False
    .Superscript = False
    .Subscript = False
    .OutlineFont = False
    .Shadow = False
    .Underline = xlUnderlineStyleNone
    .Color = -1
    .TintAndShade = 0
    .ThemeFont = xlThemeFontNone
End With
Range("AB1").Select
ActiveCell.FormulaR1C1 = "op_3fga "
With ActiveCell.Characters(Start:=1, Length:=8).Font
    .Name = "Verdana"
    .FontStyle = "Bold"
    .Size = 7.5
    .Strikethrough = False
    .Superscript = False
    .Subscript = False
    .OutlineFont = False
    .Shadow = False
    .Underline = xlUnderlineStyleNone
    .Color = -1
    .TintAndShade = 0
    .ThemeFont = xlThemeFontNone
End With
Columns("AC:AC").Select
Selection.Delete Shift:=xlToLeft
Columns("AD:AD").Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Columns("AC:AC").Select
Selection.TextToColumns Destination:=Range("AC1"), DataType:=xlDelimited, _
    TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
    Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
    :="-", FieldInfo:=Array(1, 1), TrailingMinusNumbers:=True
Range("AC1").Select
ActiveCell.FormulaR1C1 = "op_ftm"
With ActiveCell.Characters(Start:=1, Length:=6).Font
    .Name = "Verdana"
    .FontStyle = "Bold"
    .Size = 7.5
    .Strikethrough = False
    .Superscript = False
    .Subscript = False
    .OutlineFont = False
    .Shadow = False
    .Underline = xlUnderlineStyleNone
    .Color = -1
    .TintAndShade = 0
    .ThemeFont = xlThemeFontNone
End With
Range("AD1").Select
ActiveCell.FormulaR1C1 = "op_fta "
With ActiveCell.Characters(Start:=1, Length:=7).Font
    .Name = "Verdana"
    .FontStyle = "Bold"
    .Size = 7.5
    .Strikethrough = False
    .Superscript = False
    .Subscript = False
    .OutlineFont = False
    .Shadow = False
    .Underline = xlUnderlineStyleNone
    .Color = -1
    .TintAndShade = 0
    .ThemeFont = xlThemeFontNone
End With
Columns("AE:AE").Select
Selection.Delete Shift:=xlToLeft
Range("AE1").Select
ActiveCell.FormulaR1C1 = "op_off "
With ActiveCell.Characters(Start:=1, Length:=7).Font
    .Name = "Verdana"
    .FontStyle = "Bold"
    .Size = 7.5
    .Strikethrough = False
    .Superscript = False
    .Subscript = False
    .OutlineFont = False
    .Shadow = False
    .Underline = xlUnderlineStyleNone
    .Color = -1
    .TintAndShade = 0
    .ThemeFont = xlThemeFontNone
End With
Range("AF1").Select
ActiveCell.FormulaR1C1 = "op_def "
With ActiveCell.Characters(Start:=1, Length:=7).Font
    .Name = "Verdana"
    .FontStyle = "Bold"
    .Size = 7.5
    .Strikethrough = False
    .Superscript = False
    .Subscript = False
    .OutlineFont = False
    .Shadow = False
    .Underline = xlUnderlineStyleNone
    .Color = -1
    .TintAndShade = 0
    .ThemeFont = xlThemeFontNone
End With
Columns("AG:AH").Select
Selection.Delete Shift:=xlToLeft
Range("AG1").Select
ActiveCell.FormulaR1C1 = "op_pf "
With ActiveCell.Characters(Start:=1, Length:=6).Font
    .Name = "Verdana"
    .FontStyle = "Bold"
    .Size = 7.5
    .Strikethrough = False
    .Superscript = False
    .Subscript = False
    .OutlineFont = False
    .Shadow = False
    .Underline = xlUnderlineStyleNone
    .Color = -1
    .TintAndShade = 0
    .ThemeFont = xlThemeFontNone
End With
Range("AH1").Select
ActiveCell.FormulaR1C1 = "op_ast "
With ActiveCell.Characters(Start:=1, Length:=7).Font
    .Name = "Verdana"
    .FontStyle = "Bold"
    .Size = 7.5
    .Strikethrough = False
    .Superscript = False
    .Subscript = False
    .OutlineFont = False
    .Shadow = False
    .Underline = xlUnderlineStyleNone
    .Color = -1
    .TintAndShade = 0
    .ThemeFont = xlThemeFontNone
End With
Range("AI1").Select
ActiveCell.FormulaR1C1 = "op_to "
With ActiveCell.Characters(Start:=1, Length:=6).Font
    .Name = "Verdana"
    .FontStyle = "Bold"
    .Size = 7.5
    .Strikethrough = False
    .Superscript = False
    .Subscript = False
    .OutlineFont = False
    .Shadow = False
    .Underline = xlUnderlineStyleNone
    .Color = -1
    .TintAndShade = 0
    .ThemeFont = xlThemeFontNone
End With
Range("AJ1").Select
ActiveCell.FormulaR1C1 = "op_blk "
With ActiveCell.Characters(Start:=1, Length:=7).Font
    .Name = "Verdana"
    .FontStyle = "Bold"
    .Size = 7.5
    .Strikethrough = False
    .Superscript = False
    .Subscript = False
    .OutlineFont = False
    .Shadow = False
    .Underline = xlUnderlineStyleNone
    .Color = -1
    .TintAndShade = 0
    .ThemeFont = xlThemeFontNone
End With
Range("AK1").Select
ActiveCell.FormulaR1C1 = "op_stl "
With ActiveCell.Characters(Start:=1, Length:=7).Font
    .Name = "Verdana"
    .FontStyle = "Bold"
    .Size = 7.5
    .Strikethrough = False
    .Superscript = False
    .Subscript = False
    .OutlineFont = False
    .Shadow = False
    .Underline = xlUnderlineStyleNone
    .Color = -1
    .TintAndShade = 0
    .ThemeFont = xlThemeFontNone
End With
Columns("AL:AM").Select
Selection.Delete Shift:=xlToLeft
Range("T1").Select
ActiveCell.FormulaR1C1 = "to "
With ActiveCell.Characters(Start:=1, Length:=3).Font
    .Name = "Verdana"
    .FontStyle = "Bold"
    .Size = 7.5
    .Strikethrough = False
    .Superscript = False
    .Subscript = False
    .OutlineFont = False
    .Shadow = False
    .Underline = xlUnderlineStyleNone
    .Color = -1
    .TintAndShade = 0
    .ThemeFont = xlThemeFontNone
End With
Rows("1:1").Select
Range("P1").Activate
With Selection.Font
    .ThemeColor = xlThemeColorDark1
    .TintAndShade = 0
End With
Range("X1").Select

End Sub

2 个答案:

答案 0 :(得分:1)

你可以使用这样的东西来遍历你的工作表。例如,此宏只会激活每个工作表并显示一个带有名称的消息框,但您只需复制粘贴要在每个工作表上运行的代码。只是为了重申@Rdster所说的内容,您可能需要花一些时间来更好地组织代码,因为它非常笨重:)

Sub WorksheetLoop()

Dim Count1 As Integer
Dim i As Integer

'Set Count1 equal to the number of worksheets in the active workbook.

Count1 = ActiveWorkbook.Worksheets.Count

For i = 1 To Count1

    Worksheets(i).Activate

    MsgBox ActiveWorkbook.Worksheets(i).Name

Next

End Sub

答案 1 :(得分:0)

编辑此内容以满足您的需求:

 Sub Theloopofloops()

 Dim wbk As Workbook
 Dim Filename As String
 Dim path As String
 Dim rCell As Range
 Dim rRng As Range
 Dim wsO As Worksheet
 Dim sheet As Worksheet


 path = "pathtofile(s)" & "\"
 Filename = Dir(path & "*.xl??")
 Set wsO = ThisWorkbook.Sheets("Sheet1") 'included in case you need to differentiate_
              between workbooks i.e currently opened workbook vs workbook containing code

 Do While Len(Filename) > 0
     DoEvents
     Set wbk = Workbooks.Open(path & Filename, True, True)
         For Each sheet In ActiveWorkbook.Worksheets  'this needs to be adjusted for specifiying sheets. Repeat loop for each sheet so thats on a per sheet basis
                Set rRng = sheet.Range("a1:a1000") 'OBV needs to be changed
                For Each rCell In rRng.Cells
                If rCell <> "" And rCell.Value <> vbNullString And rCell.Value <> 0 Then

                   'code that does stuff

                End If
                Next rCell
         Next sheet
     wbk.Close False
     Filename = Dir
 Loop
 End Sub