Страницы: 1
RSS
Очистка неиспользуемых строк на листе, Вручную удалить выделенный диапазон не хватает памяти и книга виснет
 
Добрый день!
(Файл уже достаточно нагруженный 25 Мб - в сети)
Как можно очистить неиспользуемые строки на одном из листов начиная с 500 до 1048438
Становлюсь на 500 и вниз - строки - удалить не хватает памяти, после чего грузит процессор на 100 и только снять задачу помогает
Изменено: Тимофеев - 01.11.2022 15:04:18
 
Тимофеев, начните по чуть-чуть удалять, по 10 тысяч строк удалять и сохранятся каждый раз, потом сможете больше удалить было у меня такое
Изменено: Mershik - 01.11.2022 14:48:25
Не бойтесь совершенства. Вам его не достичь.
 
Начал с одной строки
2 Листа проблемных
Макрос так же в ошибку, но хотя бы файл не виснет виснет файл
Код
Sub ДелСтрок()
    Rows("293:1048438").Select
    Selection.Delete Shift:=xlUp
End Sub
Изменено: Тимофеев - 01.11.2022 15:03:50
 
Алгоритм нелогичный, но иногда работает.
Выделяете строки 500:1048438.
Меняете высоту строки, например, ставите 14.
Нажимаете DEL.
Удаляете эти строки.
Используемая область сбросится.
 
Получилось на 64-разрядном офисе удалить - не очень быстро - но удалилось
В 16 Мб превратилось уже полегче стало )
Изменено: Тимофеев - 01.11.2022 15:12:58
 
С просторов
Код
Sub ClearExcessRowsAndColumns()
    Dim ar As Range, r As Long, c As Long, tr As Long, tc As Long, x As Range
    Dim wksWks As Worksheet, ur As Range, arCount As Integer, i As Integer
    Dim blProtCont As Boolean, blProtScen As Boolean, blProtDO As Boolean
    Dim shp As Shape

    If ActiveWorkbook Is Nothing Then Exit Sub

    On Error Resume Next
    For Each wksWks In ActiveWorkbook.Worksheets
        Err.Clear
        Set ur = Nothing
        'Store worksheet protection settings and unprotect if protected.
        blProtCont = wksWks.ProtectContents
        blProtDO = wksWks.ProtectDrawingObjects
        blProtScen = wksWks.ProtectScenarios
        wksWks.Unprotect ""
        If Err.Number = 1004 Then
            Err.Clear
            MsgBox "'" & wksWks.Name & _
                   "' is protected with a password and cannot be checked." _
                 , vbInformation
        Else
            Application.StatusBar = "Checking " & wksWks.Name & _
                                    ", Please Wait..."
            r = 0
            c = 0

            'Determine if the sheet contains both formulas and constants
            Set ur = Union(wksWks.UsedRange.SpecialCells(xlCellTypeConstants), _
                           wksWks.UsedRange.SpecialCells(xlCellTypeFormulas))
            'If both fails, try constants only
            If Err.Number = 1004 Then
                Err.Clear
                Set ur = wksWks.UsedRange.SpecialCells(xlCellTypeConstants)
            End If
            'If constants fails then set it to formulas
            If Err.Number = 1004 Then
                Err.Clear
                Set ur = wksWks.UsedRange.SpecialCells(xlCellTypeFormulas)
            End If
            'If there is still an error then the worksheet is empty
            If Err.Number <> 0 Then
                Err.Clear
                If wksWks.UsedRange.Address <> "$A$1" Then
                    wksWks.UsedRange.EntireRow.Hidden = False
                    wksWks.UsedRange.EntireColumn.Hidden = False
                    wksWks.UsedRange.EntireRow.RowHeight = _
                    IIf(wksWks.StandardHeight <> 12.75, 12.75, 13)
                    wksWks.UsedRange.EntireColumn.ColumnWidth = 10
                    wksWks.UsedRange.EntireRow.Clear
                    'Reset column width which can also _
                     cause the lastcell to be innacurate
                    wksWks.UsedRange.EntireColumn.ColumnWidth = _
                    wksWks.StandardWidth
                    'Reset row height which can also cause the _
                     lastcell to be innacurate
                    If wksWks.StandardHeight < 1 Then
                        wksWks.UsedRange.EntireRow.RowHeight = 12.75
                    Else
                        wksWks.UsedRange.EntireRow.RowHeight = _
                        wksWks.StandardHeight
                    End If
                Else
                    Set ur = Nothing
                End If
            End If
            'On Error GoTo 0
            If Not ur Is Nothing Then
                arCount = ur.Areas.Count
                'determine the last column and row that contains data or formula
                For Each ar In ur.Areas
                    i = i + 1
                    tr = ar.Range("A1").Row + ar.Rows.Count - 1
                    tc = ar.Range("A1").Column + ar.Columns.Count - 1
                    If tc > c Then c = tc
                    If tr > r Then r = tr
                Next
                'Determine the area covered by shapes
                'so we don't remove shading behind shapes
                For Each shp In wksWks.Shapes
                    tr = shp.BottomRightCell.Row
                    tc = shp.BottomRightCell.Column
                    If tc > c Then c = tc
                    If tr > r Then r = tr
                Next
                Application.StatusBar = "Clearing Excess Cells in " & _
                                        wksWks.Name & ", Please Wait..."
                If r < wksWks.Rows.Count And r < wksWks.Cells.SpecialCells(xlCellTypeLastCell).Row Then
                    Set ur = wksWks.Rows(r + 1 & ":" & wksWks.Cells.SpecialCells(xlCellTypeLastCell).Row)
                    ur.EntireRow.Hidden = False
                    ur.EntireRow.RowHeight = IIf(wksWks.StandardHeight <> 12.75, _
                                                 12.75, 13)
                    'Reset row height which can also cause the _
                     lastcell to be innacurate
                    If wksWks.StandardHeight < 1 Then
                        ur.RowHeight = 12.75
                    Else
                        ur.RowHeight = wksWks.StandardHeight
                    End If
                    Set x = ur.Dependents
                    If Err.Number = 0 Then
                        ur.Clear
                    Else
                        Err.Clear
                        ur.Delete
                    End If
                End If
                If c < wksWks.Columns.Count And c < wksWks.Cells.SpecialCells(xlCellTypeLastCell).Column Then
                    Set ur = wksWks.Range(wksWks.Cells(1, c + 1), _
                                          wksWks.Cells(1, wksWks.Cells.SpecialCells(xlCellTypeLastCell).Column)).EntireColumn
                    ur.EntireColumn.Hidden = False
                    ur.ColumnWidth = 18

                    'Reset column width which can _
                     also cause the lastcell to be innacurate
                    ur.EntireColumn.ColumnWidth = _
                    wksWks.StandardWidth

                    Set x = ur.Dependents
                    If Err.Number = 0 Then
                        ur.Clear
                    Else
                        Err.Clear
                        ur.Delete
                    End If
                End If
            End If
        End If
        'Reset protection.
        wksWks.Protect "", blProtDO, blProtCont, blProtScen
        Err.Clear
    Next
    Application.StatusBar = False
    MsgBox "'" & ActiveWorkbook.Name & _
           "' has been cleared of excess formatting." & Chr(13) & _
           "You must save the file to keep the changes.", vbInformation
End Sub
 
В догонку
Код
Sub ПочиститьФаилZVI()
' ZVI:2009-08-08 Active workbook excess formatting clearing
' Idea & original code of Just_Jon: http://www.mrexcel.com/forum/showthread.php?t=120831
' First attempt of modification: http://www.mrexcel.com/forum/showthread.php?t=339144
' Bugs tracking:
' 1. Range("A1") fixed to .Range("A1")
' 2. Exchanging:
'   .EntireRow.RowHeight to ws.StandardHeight
'   .EntireColumn.ColumnWidth to ws.StandardWidth
' Revised:2010-06-16
' 3.(ZVI:2010-06-16) Code for StandardHeight corrected. Comments shapes are skipped
'   https://www.planetaexcel.ru/forum/index.php?PAGE_NAME=message&TID=73659&MID=617994#message617994
' 4.(ZVI:2019-03-08) Deleting of entire columns & rows is used instead of Clear method
'   https://www.planetaexcel.ru/forum/index.php?PAGE_NAME=message&TID=114886&MID=954470#message954470
  Const Title = "MrExcelDiet: Just_Jon's code modified by ZVI"
  Const vbTab2 = vbTab & vbTab
  Dim Wb As Workbook, Ws As Worksheet, LastCell As Range, Shp As Shape, Chrt As Chart
  Dim Prot As Boolean, ProtWarning As Boolean, DoCharts As Boolean
  Dim LastRow&, LastCol&, ShpLastRow&, ShpLastCol&, i&, AC, x
  Dim SheetsTotal&, SheetsCleared&, ChartsCleared&, SheetsProtSkipped&
  Dim FileNameTmp$, BytesInFileOld&, BytesInFileNew&
  ' Choose the clearing mode
  Set Wb = ActiveWorkbook
  x = MsgBox("Excess formatting clearing of " & Wb.Name & vbCr & vbCr & _
             "Apply full clearing?" & vbCr & vbCr & _
             "Yes" & vbTab & "- Full mode, including chart's AutoScaleFont=False" & vbCr & _
             "No" & vbTab & "- Medium mode, without charts processing" & vbCr & _
             "Cancel" & vbTab & "- Stop clearing & Exit", _
             vbInformation + vbYesNoCancel, _
             Title)
  If x = vbCancel Then Exit Sub
  DoCharts = (x = vbYes)
  ' Freeze on
  With Application
    .ScreenUpdating = False
    .EnableEvents = False
    AC = .Calculation: .Calculation = xlCalculationManual
  End With
  ' Calculate the old file size
  On Error Resume Next
  With CreateObject("Scripting.FileSystemObject")
    FileNameTmp = .GetSpecialFolder(2) & "\" & Wb.Name & ".TMP"
    Wb.SaveCopyAs FileNameTmp
    BytesInFileOld = .GetFile(FileNameTmp).Size
  End With
  ' Processing in each worksheet
  ProtWarning = True
  SheetsTotal = Wb.Sheets.Count
  For Each Ws In Wb.Worksheets
    With Ws
      ' Clear an error flag
      Err.Clear
      ' Inform on processing status
      Application.StatusBar = "MrExcelDiet: processing of sheet " & Ws.Name
      ' Check protection
      Prot = .ProtectContents
      ' Try to unprotect without password
      If Prot Then .Unprotect ""
      If (Err <> 0 Or .ProtectContents) And ProtWarning Then
        SheetsProtSkipped = SheetsProtSkipped + 1
        x = MsgBox(Ws.Name & " is protected and will be skipped" & vbCr & vbCr & _
                   "Skip warning on protected sheets?" & vbCr & vbCr & _
                   "Yes" & vbTab & "- Skip warning, clear sheets silently" & vbCr & _
                   "No" & vbTab & "- Warning on each protected sheets" & vbCr & _
                   "Cancel" & vbTab & "- Stop clearing & Exit", _
                   vbExclamation + vbYesNoCancel, _
                   Title)
        ProtWarning = (x = vbNo)
        If x = vbCancel Then GoTo exit_
      Else
        ' Count processed worksheets
        SheetsCleared = SheetsCleared + 1
        ' Determine the last used cell with a formula or value or comment in Ws
        Set LastCell = GetLastCell(Ws)
        ' Determine the last column and last row
        If Not LastCell Is Nothing Then
          LastCol = LastCell.Column
          LastRow = LastCell.Row
        End If
        ' Determine if any merged cells are beyond the last row
        For Each x In Range(.Cells(LastRow, 1), .Cells(LastRow, LastCol))
          If x.MergeCells Then
            With x.MergeArea
              LastRow = Max(LastRow, .Rows(.Rows.Count).Row)
            End With
          End If
        Next
        ' Determine if any merged cells are beyond the last column
        For Each x In Range(.Cells(1, LastCol), .Cells(LastRow, LastCol))
          If x.MergeCells Then
            With x.MergeArea
              LastCol = Max(LastCol, .Columns(.Columns.Count).Column)
            End With
          End If
        Next
        ' Determine if any shapes are beyond the last row and last column
        ShpLastCol = LastCol
        ShpLastRow = LastRow
        For Each Shp In .Shapes
          If Shp.Type <> msoComment Then  ' ZVI:2010-06-16
            ShpLastCol = Max(ShpLastCol, Shp.BottomRightCell.Column)
            ShpLastRow = Max(ShpLastRow, Shp.BottomRightCell.Row)
          End If
        Next
        ' Clear cells beyond the last column
        If LastCol < .Columns.Count Then
          With .Range(.Columns(LastCol + 1), .Columns(.Columns.Count))
            .EntireColumn.Delete ' rev4.
            If LastCol >= ShpLastCol Then
              ' Set StandardWidth to columns which are beyond the last col
              .EntireColumn.ColumnWidth = IIf(Ws.StandardWidth, Ws.StandardWidth, 8.43)  'Ws.StandardWidth
            End If
          End With
          If ShpLastCol < .Columns.Count Then
            ' Set StandardWidth to columns which are beyond the Shapes
            With .Range(.Columns(ShpLastCol + 1), .Columns(.Columns.Count))
              .EntireColumn.ColumnWidth = IIf(.StandardWidth, .StandardWidth, 8.43)  'Ws.StandardWidth
            End With
          End If
        End If
        ' Clear cells beyond the last row
        If LastRow < .Rows.Count Then
          With .Range(.Rows(LastRow + 1), .Rows(.Rows.Count))
            .EntireRow.Delete ' rev.4
            If LastRow >= ShpLastRow Then
              ' Set StandardWidth to rows which are beyond the last row
              .EntireRow.RowHeight = IIf(Ws.StandardHeight, Ws.StandardHeight, 12.75)
            End If
          End With
          If ShpLastRow < .Rows.Count Then
            ' Set StandardHeight to rows which are beyond the Shapes
            With .Range(.Rows(ShpLastRow + 1), .Rows(.Rows.Count))
              .EntireRow.RowHeight = IIf(.StandardHeight, .StandardHeight, 12.75)
            End With
          End If
        End If
        ' Reset last cell position of the sheet
        With .UsedRange: End With
        ' Protect the sheet if it was unprotected
        If Prot Then .Protect
      End If
      ' Apply setting to worksheet's charts: ChartArea.AutoScaleFont = False
      If DoCharts Then
        For i = 1 To .ChartObjects.Count
          Application.StatusBar = "MrExcelDiet: processing of chart " & .ChartObjects(i).Name
          .ChartObjects(i).Chart.ChartArea.AutoScaleFont = False
          ChartsCleared = ChartsCleared + 1
        Next
      End If
    End With
  Next
  ' Apply setting to workbook's charts: ChartArea.AutoScaleFont = False
  If DoCharts Then
    With Wb
      For i = 1 To .Charts.Count
        ' Clear an error flag
        Err.Clear
        ' Inform on processing status
        Application.StatusBar = "MrExcelDiet: processing of chart " & .Charts(i).Name
        ' Check chart sheet protection
        Prot = .Charts(i).ProtectContents
        ' Try to unprotect chart sheet without password
        If Prot Then .Charts(i).Unprotect ""
        If (Err <> 0 Or .Charts(i).ProtectContents) And ProtWarning Then
          SheetsProtSkipped = SheetsProtSkipped + 1
          x = MsgBox(Ws.Name & " is protected and will be skipped" & vbCr & vbCr & _
                     "Skip warning on protected sheets?" & vbCr & vbCr & _
                     "Yes" & vbTab & "- Skip warning, clear sheets silently" & vbCr & _
                     "No" & vbTab & "- Warning on each protected sheets" & vbCr & _
                     "Cancel" & vbTab & "- Stop clearing & Exit", _
                     vbExclamation + vbYesNoCancel, _
                     Title)
          ProtWarning = (x = vbNo)
          If x = vbCancel Then GoTo exit_
        Else
          ' Set AutoScaleFont = False for chart sheet
          .Charts(i).ChartArea.AutoScaleFont = False
          SheetsCleared = SheetsCleared + 1
          ChartsCleared = ChartsCleared + 1
          ' Protect the chart sheet if it was unprotected
          If Prot Then .Charts(i).Protect
        End If
      Next
    End With
  End If
exit_:
  ' Calculate the new file size
  Wb.SaveCopyAs FileNameTmp
  BytesInFileNew = CreateObject("Scripting.FileSystemObject").GetFile(FileNameTmp).Size
  Kill FileNameTmp
  ' Freeze off
  With Application
    .Calculation = AC
    .ScreenUpdating = True
    .EnableEvents = True
  End With
  ' Report on results
  Application.StatusBar = False
  x = MsgBox("Statistics of excess formatting clearing" & vbLf & vbLf & _
             "Workbook:" & vbTab & ActiveWorkbook.Name & "'" & vbLf & _
             "Sheets total:" & vbTab2 & SheetsTotal & vbLf & _
             "Sheets cleared:" & vbTab2 & SheetsCleared & vbLf & _
             "Protected sheets skipped: " & vbTab & SheetsProtSkipped & vbLf & _
             "Other sheets skipped:" & vbTab & SheetsTotal - SheetsCleared - SheetsProtSkipped & vbLf & _
             "Charts cleared:" & vbTab2 & ChartsCleared & vbLf & _
             "File size old:" & vbTab & Format(BytesInFileOld, "# ### ##0") & " Bytes" & vbLf & _
             "File size new:" & vbTab & Format(BytesInFileNew, "# ### ##0") & " Bytes" & vbLf & _
             vbLf & _
             "Save the cleared workbook to keep the changes?" & vbLf & _
             "Yes" & vbTab & "- Save & Exit" & vbLf & _
             "No" & vbTab & "- Exit without saving, cleared", _
             vbInformation + vbYesNo + IIf(BytesInFileNew < BytesInFileOld, vbDefaultButton1, vbDefaultButton2), _
             Title)
  If x = vbYes Then Wb.Save
End Sub
  
' ZVI:2009-02-02 Get last cell within values/formulas/comments of sheet Sh
' Auto-filtered & hidden rows/columns are also calculated without ShowAllData
' ActiveSheet is used if optional Sh is missing
' If VisibleOnly=True then only visible cells are searched
Function GetLastCell(Optional Sh As Worksheet, Optional VisibleOnly As Boolean) As Range
  Dim SpecCells(), rng As Range, r&, c&, x, a
  SpecCells = Array(xlCellTypeConstants, xlCellTypeFormulas, xlCellTypeComments)
  On Error Resume Next
  If Sh Is Nothing Then Set Sh = ActiveSheet
  Set rng = Sh.UsedRange
  If VisibleOnly Then Set rng = rng.SpecialCells(xlCellTypeVisible)
  For Each x In SpecCells
    For Each a In rng.SpecialCells(x).Areas
      With a.Cells(a.Rows.Count, a.Columns.Count)
        c = Max(c, .Column)
        r = Max(r, .Row)
      End With
    Next
  Next
  If r * c <> 0 Then Set GetLastCell = Sh.Cells(r, c)
End Function
  
' Aux function: max value of arguments
Private Function Max(ParamArray Values())
  Dim x
  For Each x In Values
    If x > Max Then Max = x
  Next
End Function

Страницы: 1
Наверх