ускоряя Макросы

Я не очень опытный с VBA, но с некоторой помощью на SO и много поисков я собрал эту чудовищностьускоряя Макросы

Sub All() 

Application.ScreenUpdating = False 
Application.Calculation = xlCalculationManual 

Dim nRows As Integer: nRows = Cells(Rows.Count, 1).End(xlUp).Row 
Dim cell As Range, r As Range: Set r = Range("A2:A" & nRows) 
Dim r1 As Range: Set r1 = Range("B2:B" & nRows) 
Dim Sel As Range 

ActiveSheet.UsedRange.Copy 
Sheets.Add.Name = "Original Report" 
ActiveSheet.Paste 

Application.CutCopyMode = False 

'Module1 
Worksheets("Sheet1").Activate 
ActiveSheet.Cells(1, 1).Select 

Rows(1).EntireRow.Delete 
Rows(1).EntireRow.Delete 
Rows(1).EntireRow.Delete 
Rows(1).EntireRow.Delete 
Rows(1).EntireRow.Delete 
Columns(2).EntireColumn.Delete 
Columns(3).EntireColumn.Delete 
Columns(3).EntireColumn.Delete 

ActiveSheet.UsedRange. _ 
SpecialCells(xlCellTypeLastCell). _ 
EntireRow.Delete 

ActiveSheet.UsedRange.Select 
Selection.Replace What:=Chr(160), Replacement:=Chr(32), _ 
LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False 
On Error Resume Next 
For Each cell In Intersect(Selection, _ 
    Selection.SpecialCells(xlConstants, xlTextValues)) 
    cell.Value = Application.Trim(cell.Value) 
Next cell 
On Error GoTo 0 

Columns("A:A").SpecialCells(xlCellTypeBlanks).EntireRow.Delete 

With ActiveSheet 
    .AutoFilterMode = False 
    With Range("A1", Range("A" & Rows.Count).End(xlUp)) 
     .AutoFilter 1, "TOTAL" 
     On Error Resume Next 
     .Offset(1).SpecialCells(12).EntireRow.Delete 
    End With 
    .AutoFilterMode = False 
End With 


'Module2 
Worksheets("Sheet1").Activate 
ActiveSheet.Cells(1, 1).Select 

For Each cell In r 
    If InStr(1, LCase(cell.Value), "customer:") < 1 Then cell.Value = cell.Offset(-1).Value 
Next 

Columns("I:I").SpecialCells(xlCellTypeBlanks).EntireRow.Delete 

Columns("B:B").Select 
For Each c In Selection.Cells 
    If c.Value = vbNullString Then c.Value = 0 
Next 

For Each cell In r 
If InStr(1, LCase(cell.Value), "retenue au projet") > 0 Then 
    If Sel Is Nothing Then 
     Set Sel = cell 
    Else 
     Set Sel = Union(Sel, cell) 
    End If 
End If 
Next cell 

If Not Sel Is Nothing Then 
    With Sel 
     .Select 
     Selection.EntireRow.Cut 
     Sheets.Add.Name = "Temp" 
     ActiveSheet.Paste 
    End With 
End If 

Application.CutCopyMode = False 

Worksheets("Sheet1").Activate 
Rows(1).EntireRow.Copy 

Worksheets("Temp").Activate 
Rows(1).Insert Shift:=xlDown 

Application.CutCopyMode = False 

Columns(1).EntireColumn.Delete 
Columns(2).EntireColumn.Delete 
Columns(2).EntireColumn.Delete 
Columns(2).EntireColumn.Delete 
Columns(2).EntireColumn.Delete 
Columns(2).EntireColumn.Delete 
Columns(2).EntireColumn.Delete 


ActiveSheet.UsedRange.Select 
With ActiveSheet.Sort 
.SortFields.Clear 
.SortFields.Add Key:=Selection.Columns(1), Order:=xlAscending 
.SetRange Selection 
.Header = xlYes 
.Apply 
End With 

Range("A1").Subtotal GroupBy:=1, Function:=xlSum, TotalList:=Array(2), _ 
Replace:=False, PageBreaks:=False, SummaryBelowData:=True 

ActiveSheet.Outline.ShowLevels 2 

ActiveSheet.UsedRange.SpecialCells(xlCellTypeVisible).Copy 

Sheets.Add.Name = "Unbilled Holdbacks" 
ActiveSheet.Paste 

Application.CutCopyMode = False 

ActiveSheet.UsedRange.Columns("A").Replace _ 
What:="Total", Replacement:=vbNullString, _ 
SearchOrder:=xlByColumns, MatchCase:=True 


'Module3 
Worksheets("Sheet1").Activate 
ActiveSheet.UsedRange.Select 

With ActiveSheet.Sort 
.SortFields.Clear 
.SortFields.Add Key:=Selection.Columns(1), Order:=xlAscending 
.SortFields.Add Key:=Selection.Columns(2), Order:=xlAscending 
.SetRange Selection 
.Header = xlYes 
.Apply 
End With 

Range("A1").Subtotal GroupBy:=2, Function:=xlSum, TotalList:=Array(3, 4, 5, 6, 7, 8, 9), _ 
Replace:=False, PageBreaks:=False, SummaryBelowData:=True 

For Each cell In r 
    If InStr(1, LCase(cell.Value), "customer:") < 1 Then cell.Value = cell.Offset(-1).Value 
Next 

Columns("B").SpecialCells(xlBlanks).EntireRow.Delete 

ActiveSheet.Outline.ShowLevels 2 

ActiveSheet.UsedRange.SpecialCells(xlCellTypeVisible).Copy 

Sheets.Add.Name = "Master" 
ActiveSheet.Paste 

Application.CutCopyMode = False 

With ActiveSheet.Sort 
.SortFields.Clear 
.SortFields.Add Key:=Selection.Columns(2), Order:=xlAscending 
.SetRange Selection 
.Header = xlYes 
.Apply 
End With 

ActiveSheet.UsedRange.Columns("B").Replace _ 
What:="Total", Replacement:=vbNullString, _ 
SearchOrder:=xlByColumns, MatchCase:=True 

Columns("A").SpecialCells(xlBlanks).EntireRow.Delete 

Application.DisplayAlerts = False 
Sheets("Sheet1").Delete 
Sheets("Temp").Delete 
Application.DisplayAlerts = True 

ActiveSheet.Cells(1, 1).Select 


Application.Calculation = xlCalculationAutomatic 
Application.ScreenUpdating = True 


End Sub

Я закончил отладку и делает то, что мне нужно, чтобы но для запуска требуется некоторое время. У кого-нибудь есть указатели на то, чтобы сделать это более стабильным/эффективным? Я попытался очистить буфер обмена и уменьшить количество выбора (я знаю, что все еще много, но это было намного хуже), но в некоторых случаях это повлияло на результат, и мне пришлось сохранить .Select. Любые советы о том, над чем работать, очень ценятся.

Редактировать: Что касается цели кода, то в основном это сделать неорганизованный дамп данных и отформатировать его очень определенным образом.

источник

2015-10-15 Brandon Patrick

Сначала разбейте свой макрос на разные субтитры, где каждый юг выполняет только одну конкретную задачу. Сделайте это как можно больше. Убедитесь, что у вас есть все комментарии, чтобы объяснить, что он делает. Каждая строка, которая даже немного запутанна/неоднозначна, должна быть прокомментирована с объяснением. Вы думаете, что было сложно собрать это вместе - но для вас, чтобы вы вернулись через 6 месяцев и улучшили его (или для нас, чтобы попытаться его улучшить), существует множество разных идей, ни одна из которых не ясна или не связана. –

Справедливая точка, это первоначально началось как несколько макросов, которые я объединил, следовательно, беспорядок. Поскольку я очищаю код, я обязательно буду его комментировать. –

Брэндон, вы также можете использовать http://codereview.stackexchange.com/ Это может быть больше подходит для такого рода вопросов. – MatthewD

У вашего кода довольно много избыточности. Например:

Rows(1).EntireRow.Delete 
Rows(1).EntireRow.Delete 
Rows(1).EntireRow.Delete 
Rows(1).EntireRow.Delete 
Rows(1).EntireRow.Delete

При удалении первые 5 строк может быть:

Rows("1:5").Delete xlUp

То же самое с Column части. Вы можете улучшить, если у вас есть С пунктом.

With Worksheets("Sheet1") 
    .Rows("1:5").Delete xlUp 
End With

Теперь, чтобы помочь вам в кодировании и сделать Intellisense пинок, установить объект в объявленной переменной.

Dim ws As Worksheet 
Set ws = Worksheets("Sheet1") 
Dim r As Range, c As Range 

With ws 
    .Rows("1:5").Delete xlUp 
    .Columns("A:B").Delete xlToLeft 
    .UsedRange.SpecialCells(xlCellTypeLastCell).EntireRow.Delete 
    Set r = .UsedRange 
    r.Replace What:=Chr(160), Replacement:=Chr(32), _ 
     LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False 
    For Each c In Intersect(r, r.SpecialCells(xlConstants, xlTextValues)) 
     c.Value2 = Application.Trim(c.Value2) 
    Next 

    '. 
    '. 
    'and the rest of your coding 
End With

Теперь, я не уверен, что если For Loop необходимо, но если вы можете избежать этого, это может ускорить процесс немного, как хорошо. У меня нет никаких предложений, потому что я не знаю цели. Я оставляю это как есть.

Итак, коротко, уберите свой код немного. Я оставлю остальное тебе.

источник

2015-10-16 07:14:23 L42

Отличные советы, многорядная вещь даже не пришла мне в голову. Спасибо, объявили переменные. –

Я правильно понял, что, например, диапазон r может быть установлен в разные значения в разных предложениях С? –

@BrandonPatrick Да. 'r' является переменной _Range Type_. Итак, из самого слова _variable_, его можно установить и сбросить в любом месте вашего кода. Но убедитесь, что вы контролируете его и следуете логике вашего набора, чтобы получить ожидаемый результат. Запишите часть кода, проверьте ее и как только они сделают то, что вы ожидаете от нее, соедините их. Таким образом, вы сможете контролировать поток, время выполнения и предвидеть ошибки. – L42

Это не касается непосредственно кода, но, попробуйте отступить от него и научиться использовать объекты с помощью простых задач на чистом листе. Затем вы поймете, как применить их к вашему коду.

Dim ws as Excel.Worksheet 
Set ws = ActiveWorkbook.Sheets("Sheet1")

Тогда даже без его активации или выбрав что-либо на нем, вы можете сделать что-нибудь такое, как

Работа с диапазонами

ws.Range("A" & lRow).NumberFormat = "@" 
ws.Range("F" & lRow).Value = "SomeText" 

if ws.Range("F" & lRow).Value = "somevalue" then 
    'Do something 
End if

Удаление строк

ws.Rows(lRow).EntireRow.Delete

Получить лист свойства.

Dim str As String 
str = ws.name 
msgbox (str)

Это в значительной степени идет

Application -> Workbook -> Рабочий лист -> Любой объект на листе

источник

2015-10-15 20:32:10 MatthewD

Я попробую, кажется, у меня есть много нового, чтобы учиться в VBA. –

Application.ScreenUpdating = False

запустить макрос

Application.ScreenUpdating = true

источник

2015-10-15 21:02:54 milevyo

ускоряя Макросы

ответ

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