我从几个月开始一直在运行此代码，平均需要10分钟才能运行。今天已经半个小时了。 10分钟似乎也很长。谁能指导可能是什么问题？我在使用不必要的行吗？
Sub bench_extraction()
Dim countrows As Integer
Dim reqdcol As Integer
Dim skilllen As Integer
Dim LastRow As Long
Dim sht As Worksheet
Dim LastColumn As Long
Dim wscopy As Worksheet
Dim In_S As Worksheet
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Set sht = ThisWorkbook.Sheets("Benchreport")
'Create copy of Bench report
sht.Copy ThisWorkbook.Sheets(Sheets.Count)
'Rename new bench report
ActiveSheet.Name = "Benchreport_Working"
Set wscopy = Sheets("Benchreport_Working")
Set StartCell = wscopy.Range("A1")
wscopy.Activate
LastRow = wscopy.Cells(wscopy.Rows.Count, StartCell.Column).End(xlUp).Row
LastColumn = wscopy.Cells(1, 1).End(xlToRight).Column
'count number of max cells
countrows = LastRow - 1
'Find column no. in file
reqdcol = wscopy.Range("1:1").Find("Bench Type", , xlValues, xlWhole, , , True).Column
reqdcol_1 = wscopy.Range("1:1").Find("Bench Ageing", , xlValues, xlWhole, , , True).Column
reqdcol_2 = wscopy.Range("1:1").Find("Availability Status", , xlValues, xlWhole, , , True).Column
reqdcol_3 = wscopy.Range("1:1").Find("User Payroll Location (current)", , xlValues, xlWhole, , , True).Column
reqdcol_4 = wscopy.Range("1:1").Find("Detail Skill Set", , xlValues, xlWhole, , , True).Column
Worksheets("Benchreport_working").UsedRange
wscopy.UsedRange.Select
'Apply filter on Partial Bench
ActiveSheet.UsedRange.AutoFilter Field:=reqdcol, Criteria1:="Partial Bench"
'check if partial bench is found
check = wscopy.AutoFilter.Range.Columns(1).SpecialCells(xlCellTypeVisible).Cells.Count - 1
If check > 0 Then
Application.DisplayAlerts = False
wscopy.Range("A2:A" & LastRow).SpecialCells(xlCellTypeVisible).EntireRow.Delete
Application.DisplayAlerts = True
End If
'Clear all filters
wscopy.Cells.AutoFilter
check = 0
'Apply filter on Future Bench
ActiveSheet.UsedRange.AutoFilter Field:=reqdcol, Criteria1:="Future Bench"
'Apply filter on days less than -30
ActiveSheet.UsedRange.AutoFilter Field:=reqdcol_1, Criteria1:="<" & -30
ActiveSheet.UsedRange.AutoFilter Field:=reqdcol_2, Criteria1:="<>" & "Confirm release"
'check if any rows are found
check = wscopy.AutoFilter.Range.Columns(1).SpecialCells(xlCellTypeVisible).Cells.Count - 1
If check > 0 Then
Application.DisplayAlerts = False
wscopy.Range("A2:A" & LastRow).SpecialCells(xlCellTypeVisible).EntireRow.Delete
Application.DisplayAlerts = True
End If
'Clear all filters
wscopy.Cells.AutoFilter
check = 0
'Apply filter on Future Bench
ActiveSheet.UsedRange.AutoFilter Field:=reqdcol, Criteria1:="Existing Bench-Future Allocation"
'check if any rows are found
check = wscopy.AutoFilter.Range.Columns(1).SpecialCells(xlCellTypeVisible).Cells.Count - 1
If check > 0 Then
Application.DisplayAlerts = False
wscopy.Range("A2:A" & LastRow).SpecialCells(xlCellTypeVisible).EntireRow.Delete
Application.DisplayAlerts = True
End If
'Clear all filters
wscopy.Cells.AutoFilter
check = 0
'Apply filter on Availibility status
ActiveSheet.UsedRange.AutoFilter Field:=reqdcol_2, Criteria1:="Leave Exclusion"
'check if any rows are found
check = wscopy.AutoFilter.Range.Columns(1).SpecialCells(xlCellTypeVisible).Cells.Count - 1
If check > 0 Then
Application.DisplayAlerts = False
wscopy.Range("A2:A" & LastRow).SpecialCells(xlCellTypeVisible).EntireRow.Delete
Application.DisplayAlerts = True
End If
'Clear all filters
wscopy.Cells.AutoFilter
check = 0
'Apply filter on Availibility status
ActiveSheet.UsedRange.AutoFilter Field:=reqdcol_2, Criteria1:="NTP Allocation"
'check if any rows are found
check = wscopy.AutoFilter.Range.Columns(1).SpecialCells(xlCellTypeVisible).Cells.Count - 1
If check > 0 Then
Application.DisplayAlerts = False
wscopy.Range("A2:A" & LastRow).SpecialCells(xlCellTypeVisible).EntireRow.Delete
Application.DisplayAlerts = True
End If
'Clear all filters
wscopy.Cells.AutoFilter
check = 0
'Apply filter on Availibility status
ActiveSheet.UsedRange.AutoFilter Field:=reqdcol_2, Criteria1:="Resign"
'check if any rows are found
check = wscopy.AutoFilter.Range.Columns(1).SpecialCells(xlCellTypeVisible).Cells.Count - 1
If check > 0 Then
Application.DisplayAlerts = False
wscopy.Range("A2:A" & LastRow).SpecialCells(xlCellTypeVisible).EntireRow.Delete
Application.DisplayAlerts = True
End If
'Clear all filters
wscopy.Cells.AutoFilter
check = 0
'Apply filter on Location
ActiveSheet.UsedRange.AutoFilter Field:=reqdcol_3, Criteria1:="=" & "*Germany"
'check if any rows are found
check = wscopy.AutoFilter.Range.Columns(1).SpecialCells(xlCellTypeVisible).Cells.Count - 1
If check > 0 Then
Application.DisplayAlerts = False
wscopy.Range("A2:A" & LastRow).SpecialCells(xlCellTypeVisible).EntireRow.Delete
Application.DisplayAlerts = True
End If
'Clear all filters
wscopy.Cells.AutoFilter
check = 0
'Apply filter on Location
ActiveSheet.UsedRange.AutoFilter Field:=reqdcol_3, Criteria1:="=" & "NGR-DE-ANEGMBH"
'check if any rows are found
check = wscopy.AutoFilter.Range.Columns(1).SpecialCells(xlCellTypeVisible).Cells.Count - 1
If check > 0 Then
Application.DisplayAlerts = False
wscopy.Range("A2:A" & LastRow).SpecialCells(xlCellTypeVisible).EntireRow.Delete
Application.DisplayAlerts = True
End If
'Clear all filters
wscopy.Cells.AutoFilter
check = 0
'Apply filter on Location
ActiveSheet.UsedRange.AutoFilter Field:=reqdcol_3, Criteria1:="=" & "*Romania"
'check if any rows are found
check = wscopy.AutoFilter.Range.Columns(1).SpecialCells(xlCellTypeVisible).Cells.Count - 1
If check > 0 Then
Application.DisplayAlerts = False
wscopy.Range("A2:A" & LastRow).SpecialCells(xlCellTypeVisible).EntireRow.Delete
Application.DisplayAlerts = True
End If
'Clear all filters
wscopy.Cells.AutoFilter
check = 0
'Apply filter on Location
ActiveSheet.UsedRange.AutoFilter Field:=reqdcol_3, Criteria1:="=" & "*Austria"
'check if any rows are found
check = wscopy.AutoFilter.Range.Columns(1).SpecialCells(xlCellTypeVisible).Cells.Count - 1
If check > 0 Then
Application.DisplayAlerts = False
wscopy.Range("A2:A" & LastRow).SpecialCells(xlCellTypeVisible).EntireRow.Delete
Application.DisplayAlerts = True
End If
'Clear all filters
wscopy.Cells.AutoFilter
check = 0
'Apply filter on Location
ActiveSheet.UsedRange.AutoFilter Field:=reqdcol_3, Criteria1:="=" & "*Norway"
'check if any rows are found
check = wscopy.AutoFilter.Range.Columns(1).SpecialCells(xlCellTypeVisible).Cells.Count - 1
If check > 0 Then
Application.DisplayAlerts = False
wscopy.Range("A2:A" & LastRow).SpecialCells(xlCellTypeVisible).EntireRow.Delete
Application.DisplayAlerts = True
End If
'Clear all filters
wscopy.Cells.AutoFilter
check = 0
'Apply filter on Location
ActiveSheet.UsedRange.AutoFilter Field:=reqdcol_4, Criteria1:=vbNullString
'check if any rows are found
check = wscopy.AutoFilter.Range.Columns(1).SpecialCells(xlCellTypeVisible).Cells.Count - 1
If check > 0 Then
Application.DisplayAlerts = False
wscopy.Range("A2:A" & LastRow).SpecialCells(xlCellTypeVisible).EntireRow.Delete
Application.DisplayAlerts = True
End If
wscopy.Cells.AutoFilter
check = 0
'Data is clean by now
'Duplicate the rows basis the skill set
For currentColumn = ActiveSheet.UsedRange.Columns.Count To 1 Step -1
columnHeading = ActiveSheet.UsedRange.Cells(1, currentColumn).Value
'CHECK WHETHER TO KEEP THE COLUMN
Select Case columnHeading
Case "User Person Number", "User Name", "Detail Skill Set", "Bench Type", "Bench Ageing", "Active Blocker"
'Do nothing
Case Else
ActiveSheet.Columns(currentColumn).Delete
End Select
Next
LastRow = wscopy.Cells(wscopy.Rows.Count, StartCell.Column).End(xlUp).Row
LastColumn = wscopy.Cells(1, 1).End(xlToRight).Column
'count number of max cells
countrows = LastRow - 1
reqdcol_4 = wscopy.Range("1:1").Find("Detail Skill Set", , xlValues, xlWhole, , , True).Column
check = 2
'Divide the colleagues basis number of skills
Do
strl = wscopy.Cells(check, reqdcol_4)
skilllen = Len(strl)
strl = Application.WorksheetFunction.Substitute(strl, ",", vbNullString)
commacount = skilllen - Len(strl)
If commacount <> 0 Then
i = 0
For i = 1 To commacount
wscopy.Cells(check, reqdcol_4).Select
ActiveCell.Offset(1, 0).EntireRow.Insert
ActiveCell.EntireRow.Copy ActiveCell.Offset(1, 0).EntireRow
check = check + 1
Next
End If
LastRow = wscopy.Cells(wscopy.Rows.Count, StartCell.Column).End(xlUp).Row
countrows = LastRow + 1
check = check + 1
Loop Until check = countrows
'Divide the skills
check = 2
Do
strl = wscopy.Cells(check, reqdcol_4)
skilllen = Len(strl)
strl = Application.WorksheetFunction.Substitute(strl, ",", vbNullString)
commacount = skilllen - Len(strl)
strl = wscopy.Cells(check, reqdcol_4).Value
i = 0
a = 1
comm = 1
If commacount <> 0 Then
If commacount > 1 Then
For i = 1 To commacount - 1
If i = 1 Then
comm = InStr(a, strl, ",", vbBinaryCompare)
wscopy.Cells(check, reqdcol_4) = Mid(strl, 1, comm - 1)
End If
a = comm + 1
comm = InStr(comm + 1, strl, ",", vbBinaryCompare)
wscopy.Cells(check + 1, reqdcol_4) = Mid(strl, a, comm - a)
' comm = InStr(comm + 1, strl, ",", vbBinaryCompare)
' wscopy.Cells(i + 1, reqdcol_4) = Mid(strl, comm + 1, comm - (comm + 1))
check = check + 1
Next
'comm = InStr(comm + 1, strl, ",", vbBinaryCompare)
wscopy.Cells(check + 1, reqdcol_4) = Right(strl, Len(strl) - comm)
check = Cells(check + 1, reqdcol_4).Row
Else
comm = InStr(a, strl, ",", vbBinaryCompare)
wscopy.Cells(check, reqdcol_4) = Mid(strl, 1, comm - 1)
a = comm + 1
wscopy.Cells(check + 1, reqdcol_4) = Right(strl, Len(strl) - comm)
check = Cells(check + 1, reqdcol_4).Row
End If
End If
LastRow = wscopy.Cells(wscopy.Rows.Count, StartCell.Column).End(xlUp).Row
countrows = LastRow + 1
check = check + 1
Loop Until check = countrows
'Check for nan skill and remove it
check = 0
'Apply filter on Location
ActiveSheet.UsedRange.AutoFilter Field:=reqdcol_4, Criteria1:="nan"
'check if any rows are found
check = wscopy.AutoFilter.Range.Columns(1).SpecialCells(xlCellTypeVisible).Cells.Count - 1
If check > 0 Then
Application.DisplayAlerts = False
wscopy.Range("A2:A" & LastRow).SpecialCells(xlCellTypeVisible).EntireRow.Delete
Application.DisplayAlerts = True
End If
wscopy.Cells.AutoFilter
'Set dynamic range
ActiveWorkbook.Names.Add Name:="Bench_Data", RefersToR1C1:= _
"=OFFSET(Benchreport_Working!R1C1,0,0,COUNTA(Benchreport_Working!C1),COUNTA(Benchreport_Working!R1))"
ActiveWorkbook.Names("Bench_Data").Comment = ""
'Dim tbl As ListObject
'wscopy.UsedRange.Select
'Set tbl = wscopy.ListObjects.Add(xlSrcRange, Selection, , xlYes)
'tbl.TableStyle = "TableStyleLight8"
'tbl.Name = "Bench_ Data"
Set In_S = Sheets("Initial steps")
reqdcol_4 = wscopy.Range("1:1").Find("Detail Skill Set", , xlValues, xlWhole, , , True).Column
wscopy.Columns(reqdcol_4).Copy
Sheets("Initial Steps").Activate
In_S.Range("L:L").Select
Selection.PasteSpecial Paste:=xlPasteValues
LastColumn = wscopy.Cells(1, 1).End(xlToRight).Column
reqdcol_5 = wscopy.Range("1:1").Find("User Person Number", , xlValues, xlWhole, , , True).Column
wscopy.Columns(reqdcol_5).Copy
Sheets("Initial Steps").Activate
In_S.Range("N:N").Select
Selection.PasteSpecial Paste:=xlPasteValues
ActiveSheet.Range("N:N").RemoveDuplicates Columns:=1, Header:=xlNo
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
请告知我该怎么做才能使其运行更快。我想做的是根据一些条件清理数据，然后通过循环，将一行具有的技能数分成多行。例如，第一行具有5种技能（Java，SQL，AngularJS，VBA，Python），然后循环会将行分为5行，分别为第一行：Java，第二行：SQL等。这是代码花费时间最长的地方时间。