Превосходный макрос для нанесения на все листы

-2

У меня есть предел с несколькими листами. Я создал макрос на одном листе с приведенным ниже макрокодом. Как я могу отредактировать этот код, который будет применяться на всех листах рабочей книги за один проход. СпасибоПревосходный макрос для нанесения на все листы

Sub таблица очков() ' ' ПРОТОКОЛ Macro '

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

источник

2016-11-30 Tarek Khedr

Вы должны Google проходного листов в VBA. –

Можете ли вы показать мне, как это? Я не разработчик. Спасибо –

Ничего себе, этот код рекордера многословие ... очистите его некоторыми с http://stackoverflow.com/questions/10714251/how-to-avoid-using-select-in-excel-vba-macros – Rdster

Вы можете использовать что-то вроде это для прокрутки ваших рабочих листов. В качестве примера этот макрос только активирует каждый лист и показывает окно с именем, но вам просто нужно скопировать какой код вы хотите запускать на каждом листе на своем месте. И только повторить то, что @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

источник

2016-11-30 14:39:36

Спасибо, я попробую –

Активация листов не нужна и неаккуратная. Что, если есть тонны листов? Вы хотите, чтобы его сценарий работал вечно? lol –

Ха-ха, я просто включил его в качестве примера для работы. Включите то, что вы будете;) –

Редактировать это в соответствии с вашими потребностями:

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

источник

2016-11-30 14:39:35

Превосходный макрос для нанесения на все листы

ответ

Смежные вопросы