当我运行代码时，它会冻结，但是当我插入Application.Wait (Now + TimeValue("0:00:02"))时，它将可以正常工作。我只是想知道为什么要这么做。这是第一次发生这样的事情。任何帮助，将不胜感激。谢谢！
Public Sub Run()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Call Import
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
Private Sub Import()
Dim fd As FileDialog
Dim FileChosen As Integer
Dim FileName As String
Dim tempWB As Workbook
Set fd = Application.FileDialog(msoFileDialogFilePicker)
fd.InitialFileName = "X:\Dump Report for Loans"
fd.InitialView = msoFileDialogViewList
fd.AllowMultiSelect = True
FileChosen = fd.Show
If FileChosen = -1 Then
Call Sort
Application.Wait (Now + TimeValue("0:00:02")) 'Heres where it trips
Call Save_As
Else:
Exit Sub
End If
End Sub
Private Sub Sort()
Dim fd As FileDialog
Dim tempWB As Workbook
Dim i As Integer
Dim rwCnt As Long
Dim rngSrt As Range
Dim shRwCnt As Long
Set fd = Application.FileDialog(msoFileDialogFilePicker)
For i = 1 To fd.SelectedItems.Count
Set tempWB = Workbooks.Open(fd.SelectedItems(i))
With tempWB.Worksheets(1)
rwCnt = .Cells(Rows.Count, 1).End(xlUp).Row
If .Range("A1") <> "* as of *" Then
If .Cells(rwCnt - 1, 1).NumberFormat = "mmm d, yyyy" Then
.Range("A1") = .Range("A1").Value & " as of " & .Cells(rwCnt - 1, 1)
.Rows(rwCnt - 1 & ":" & rwCnt).Delete shift:=xlShiftUp
rwCnt = rwCnt - 2
End If
End If
Set rngSrt = .Range("A2:AR" & rwCnt)
With .Sort
.SortFields.Clear
.SortFields.Add Key:=Range("E2:E" & rwCnt), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.SetRange rngSrt
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
.Columns("F:F").Insert shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
For x = rwCnt To 4 Step -1
.Cells(x, 6).Value2 = (.Cells(x, 5).Value2 - .Cells(x - 1, 5).Value2)
Next x
For Z = rwCnt To 3 Step -1
If .Cells(Z, 6).Value = 0 Then
.Rows(Z).Delete shift:=xlShiftUp
End If
Next Z
.Columns("F:F").Delete
.Columns("A:AR").AutoFit
Organize fd, tempWB, i, rwCnt
Summary fd, tempWB, i
End With
Next i
tempWB.Worksheets(2).Activate
tempWB.Worksheets(1).Visible = xlSheetHidden
End Sub
Private Sub Organize(fd As FileDialog, tempWB As Workbook, i As Integer, rwCnt As Long)
Dim rngSrt As Range
Dim shRwCnt As Long
With tempWB.Worksheets(1)
rwCnt = .Cells(Rows.Count, 1).End(xlUp).Row
.Range("A1") = .Range("A1").Value & " as of " & .Cells(rwCnt - 1, 1)
.Rows(rwCnt - 1 & ":" & rwCnt).Delete shift:=xlShiftUp
rwCnt = rwCnt - 2
Set rngSrt = .Range("A2:AR" & rwCnt)
With .Sort
.SortFields.Clear
.SortFields.Add Key:=Range("AR2:AR" & rwCnt), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.SortFields.Add Key:=Range("E2:E" & rwCnt), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.SetRange rngSrt
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
For x = rwCnt To 3 Step -1
If .Cells(x, 5).Value = .Cells(x - 1, 5).Value Then
.Rows(x).Delete shift:=xlShiftUp
End If
Next x
rwCnt = .Cells(Rows.Count, 1).End(xlUp).Row
For y = 3 To rwCnt
Dim WsDest As Worksheet
Set WsDest = Nothing
On Error Resume Next 'try to find the worksheet
Set WsDest = Worksheets(Left$(.Cells(y, 44).Value, 31)) 'worksheet names are limited to 31 characters
On Error GoTo 0 're-activate error reporting
If WsDest Is Nothing Then 'if ws does not exist
'add this sheet name it and copy/paste
Set WsDest = Worksheets.Add(, Worksheets(Sheets.Count))
WsDest.Name = Left$(.Cells(y, 44).Value, 31) 'worksheet names are limited to 31 characters
.Range("A1:AR2").Copy
WsDest.Cells(1, 1).PasteSpecial Paste:=xlPasteAllUsingSourceTheme, _
Operation:=xlNone, SkipBlanks:=False, Transpose:=False
.Rows(y).Copy
WsDest.Cells(3, 1).PasteSpecial Paste:=xlPasteAllUsingSourceTheme, _
Operation:=xlNone, SkipBlanks:=False, Transpose:=False
WsDest.Tab.ColorIndex = 3
WsDest.Columns("A:AR").AutoFit
Else
'find last used row and copy/paste
shRwCnt = WsDest.Cells(WsDest.Rows.Count, 1).End(xlUp).Row
.Rows(y).Copy
WsDest.Cells(shRwCnt + 1, 1).PasteSpecial Paste:=xlPasteAllUsingSourceTheme, _
Operation:=xlNone, SkipBlanks:=False, Transpose:=False
WsDest.Columns("A:AR").AutoFit
End If
Next y
.Columns("A:AR").AutoFit
End With
tempWB.Worksheets(1).Activate
End Sub
Private Sub Summary(fd As FileDialog, tempWB As Workbook, i As Integer)
Dim x As Integer
Dim wb As Workbook: Set wb = tempWB
Dim strName As String: strName = "Summary"
Dim ws As Worksheet
Set ws = wb.Sheets.Add(Type:=xlWorksheet, after:=wb.Worksheets(1))
Dim rwCnt As Long
Dim PCsht As Worksheet
With ws
.Name = strName
For x = 3 To Sheets.Count
Set PCsht = tempWB.Worksheets(x)
rwCnt = PCsht.Cells(Rows.Count, 1).End(xlUp).Row
.Cells(x, 1) = PCsht.Name
.Cells(x, 2) = WorksheetFunction.Sum(Range(PCsht.Cells(3, 11), PCsht.Cells(rwCnt, 11)))
Next x
.Cells(2, 1) = "Purpose Code"
.Cells(2, 2) = "Net Active Principle Balance"
.Cells(Sheets.Count + 1, 1) = "TOTAL"
.Cells(Sheets.Count + 1, 2) = WorksheetFunction.Sum(Range(ws.Cells(3, 2), ws.Cells(Sheets.Count, 2)))
.Columns("A:B").AutoFit
.Range(.Cells(3, 2), Cells(Sheets.Count + 1, 2)).NumberFormat = "$#,##0.00"
End With
End Sub
Private Sub Save_As()
Dim bFileSaveAs As Boolean
bFileSaveAs = Application.Dialogs(xlDialogSaveAs).Show
If Not bFileSaveAs Then MsgBox "User cancelled", vbCritical
End Sub