Блог

Я должен запустить этот код на листе из более чем 5000 строк. На данный момент я мог бы сделать это быстрее вручную. Мне нужно добавить новую строку, перенести несколько значений из предыдущей строки, создать промежуточные итоги и изменить форму везде, где есть изменения в столбце «G». Этот код начнется в строке 8 и должен быть применен только к ячейкам E:X. Есть ли лучший способ сделать это?

При дальнейшем тестировании, похоже, проблема в том, что мне приходится добавлять сотни строк по отдельности. Есть ли способ найти все строки, в которых значение не равно указанному выше, и добавить все строки в массовом порядке?

 Sub subtotals()  'counter variables cs = 8 c = 8   Do Until Range("E" amp; r) = ""   c = r cs = r  'Do until Material Column does not equal material above Do Until Range("g" amp; r) lt;gt; Range("g" amp; r   1) c = c   1 r = r   1 Loop  r = r   1  Rows(r).Insert  'total label in SECTION x = "e" Range(x amp; r) = "Total"  x = "q" Range(x amp; r).Formula = "=sum(" amp; x amp; cs amp; ":" amp; x amp; c amp; ")"  'rows to shade Range("E" amp; r, "x" amp; r).Locked = True Range("E" amp; r, "x" amp; r).Select  'shading With Selection.Interior .PatternColorIndex = xlAutomatic .ThemeColor = xlThemeColorDark2 .TintAndShade = -0.499984740745262 .PatternTintAndShade = 0 End With With Selection.Font .ThemeColor = xlThemeColorDark1 .TintAndShade = 0 .Bold = True End With Selection.HorizontalAlignment = xlCenter  r = r   1  Loop End Sub  

Вставка Промежуточных Итогов

• До тысячи вставленных строк это будет работать, т. е. это займет несколько секунд. После этого это может занять целую вечность.
• Попробуйте внедрить Application.Calculation и Application.ScreenUpdating в свой код. Его использование довольно просто. Это ускорит ваш код.

 Option Explicit  Sub InsertSubtotals()    Const wsName As String = "Sheet1" ' adjust  Const fRow As Long = 8 ' First Row  Const tCol As String = "E" ' Total Column  Const cCol As String = "G" ' Criteria (Search) Column  Const fCol As String = "Q" ' Formula Column  Const fCols As String = "E:X" ' Format Columns    Dim wb As Workbook: Set wb = ThisWorkbook ' Workbook containing this code   Dim ws As Worksheet: Set ws = wb.Worksheets(wsName)  Dim lRow As Long: lRow = ws.Cells(ws.Rows.Count, tCol).End(xlUp).Row  If lRow lt; fRow Then Exit Sub ' no data   Dim pRow As Long: pRow = lRow   1   Application.ScreenUpdating = False  Application.Calculation = xlCalculationManual   Dim trg As Range ' Total Range  Dim OldValue As Variant  Dim NewValue As Variant  Dim r As Long  Dim pFormula As String    For r = pRow To fRow   1 Step -1  NewValue = ws.Cells(r - 1, cCol).Value  If StrComp(CStr(NewValue), CStr(OldValue), vbTextCompare) lt;gt; 0 Then  If pRow gt; r Then  WriteFormula ws, r, pRow, fCol  pRow = r  End If  ws.Rows(r).Insert  If Not trg Is Nothing Then  Set trg = Union(trg, ws.Cells(r, tCol))  Else  Set trg = ws.Cells(r, tCol)  End If  OldValue = NewValue  End If  Next r  WriteFormula ws, fRow, pRow, fCol    ' Write 'Total' in one go.  trg.Value = "Total"    ' Apply formatting in one go.  With Intersect(trg.EntireRow, ws.Columns(fCols))  .Locked = True  With .Interior  .PatternColorIndex = xlAutomatic  .ThemeColor = xlThemeColorDark2  .TintAndShade = -0.499984740745262  .PatternTintAndShade = 0  End With  With .Font  .ThemeColor = xlThemeColorDark1  .TintAndShade = 0  .Bold = True  End With  .HorizontalAlignment = xlCenter  End With   Application.Calculation = xlCalculationAutomatic  Application.ScreenUpdating = True  End Sub  Sub WriteFormula( _  ByVal ws As Worksheet, _  ByVal r As Long, _  ByVal pRow As Long, _  ByVal ColumnString As String)  Dim pFormula As String  pFormula = "=SUM(" amp; ColumnString amp; r amp; ":" amp; ColumnString amp; pRow - 1 amp; ")"  ws.Cells(pRow, ColumnString).Formula = pFormula End Sub