Question

我对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。任何有关工作内容的建议都非常感谢。

编辑：关于代码的目的，主要是采取一种无组织的数据转储并以非常具体的方式对其进行格式化。

Answer 1

您的代码有很多冗余。例如：

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 Clause ，也可以改进。

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 是否有必要，但如果你可以消除它，它可能会加快速度。我没有任何建议，因为我不知道目的。我保持原样。

简而言之，请稍微整理一下代码。我把剩下的留给你了。

Answer 2

这不会直接解决您的代码问题，但请尝试逐步解决它并学习如何在空白工作表上使用带有一些简单任务的对象。然后，您将了解如何将它们应用于您的代码。

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)

获取工作表属性。

{{1}}

它几乎是

申请 - ＆gt;工作簿 - ＆gt;工作表 - ＆gt;工作表上的任何对象

Answer 3

Application.ScreenUpdating = False

运行宏

Application.ScreenUpdating = true

加速宏

3 个答案: