目前這需要大約 30 分鐘才能完成，因為 if 條件正在檢查 25000 多行和 168 列。這只是一個函式，我還需要制作大約 10 個這樣的函式，所以程式需要很長時間才能完成。有什么辦法可以讓這更快更簡單。任何幫助將不勝感激..謝謝
Sub SumBasicPay()
Application.ScreenUpdating = False
Dim total As Double
Dim ws1 As Worksheet
Dim LastRow As Long
Set ws1 = ThisWorkbook.Worksheets("Main")
Worksheets("Database").Activate
LastRow = Range("A1").CurrentRegion.Rows.Count
For iRow = 2 To LastRow
total = 0
For iCol = 17 To 168
If Cells(1, iCol).Value = Sheet12.Range("A7") And Sheet12.Range("B7") = " " Then
total = total Cells(iRow, iCol).Value
End If
If Cells(1, iCol).Value = Sheet12.Range("A7") And Sheet12.Range("B7") = "-" Then
total = total - Cells(iRow, iCol).Value
End If
If Cells(1, iCol).Value = Sheet12.Range("A8") And Sheet12.Range("B8") = " " Then
total = total Cells(iRow, iCol).Value
End If
If Cells(1, iCol).Value = Sheet12.Range("A8") And Sheet12.Range("B8") = "-" Then
total = total - Cells(iRow, iCol).Value
End If
If Cells(1, iCol).Value = Sheet12.Range("A9") And Sheet12.Range("B9") = " " Then
total = total Cells(iRow, iCol).Value
End If
If Cells(1, iCol).Value = Sheet12.Range("A9") And Sheet12.Range("B9") = "-" Then
total = total - Cells(iRow, iCol).Value
End If
If Cells(1, iCol).Value = Sheet12.Range("A10") And Sheet12.Range("B10") = " " Then
total = total Cells(iRow, iCol).Value
End If
If Cells(1, iCol).Value = Sheet12.Range("A10") And Sheet12.Range("B10") = "-" Then
total = total - Cells(iRow, iCol).Value
End If
If Cells(1, iCol).Value = Sheet12.Range("A11") And Sheet12.Range("B11") = " " Then
total = total Cells(iRow, iCol).Value
End If
If Cells(1, iCol).Value = Sheet12.Range("A11") And Sheet12.Range("B11") = "-" Then
total = total - Cells(iRow, iCol).Value
End If
If Cells(1, iCol).Value = Sheet12.Range("A12") And Sheet12.Range("B12") = " " Then
total = total Cells(iRow, iCol).Value
End If
If Cells(1, iCol).Value = Sheet12.Range("A12") And Sheet12.Range("B12") = "-" Then
total = total - Cells(iRow, iCol).Value
End If
If Cells(1, iCol).Value = Sheet12.Range("A13") And Sheet12.Range("B13") = " " Then
total = total Cells(iRow, iCol).Value
End If
If Cells(1, iCol).Value = Sheet12.Range("A13") And Sheet12.Range("B13") = "-" Then
total = total - Cells(iRow, iCol).Value
End If
If Cells(1, iCol).Value = Sheet12.Range("A14") And Sheet12.Range("B14") = " " Then
total = total Cells(iRow, iCol).Value
End If
If Cells(1, iCol).Value = Sheet12.Range("A14") And Sheet12.Range("B14") = "-" Then
total = total - Cells(iRow, iCol).Value
End If
If Cells(1, iCol).Value = Sheet12.Range("A15") And Sheet12.Range("B15") = " " Then
total = total Cells(iRow, iCol).Value
End If
If Cells(1, iCol).Value = Sheet12.Range("A15") And Sheet12.Range("B15") = "-" Then
total = total - Cells(iRow, iCol).Value
End If
If Cells(1, iCol).Value = Sheet12.Range("A16") And Sheet12.Range("B16") = " " Then
total = total Cells(iRow, iCol).Value
End If
If Cells(1, iCol).Value = Sheet12.Range("A16") And Sheet12.Range("B16") = "-" Then
total = total - Cells(iRow, iCol).Value
End If
If Cells(1, iCol).Value = Sheet12.Range("A17") And Sheet12.Range("B17") = " " Then
total = total Cells(iRow, iCol).Value
End If
If Cells(1, iCol).Value = Sheet12.Range("A17") And Sheet12.Range("B17") = "-" Then
total = total - Cells(iRow, iCol).Value
End If
If Cells(1, iCol).Value = Sheet12.Range("A18") And Sheet12.Range("B18") = " " Then
total = total Cells(iRow, iCol).Value
End If
If Cells(1, iCol).Value = Sheet12.Range("A18") And Sheet12.Range("B18") = "-" Then
total = total - Cells(iRow, iCol).Value
End If
If Cells(1, iCol).Value = Sheet12.Range("A19") And Sheet12.Range("B19") = " " Then
total = total Cells(iRow, iCol).Value
End If
If Cells(1, iCol).Value = Sheet12.Range("A19") And Sheet12.Range("B19") = "-" Then
total = total - Cells(iRow, iCol).Value
End If
If Cells(1, iCol).Value = Sheet12.Range("A20") And Sheet12.Range("B20") = " " Then
total = total Cells(iRow, iCol).Value
End If
If Cells(1, iCol).Value = Sheet12.Range("A20") And Sheet12.Range("B20") = "-" Then
total = total - Cells(iRow, iCol).Value
End If
If Cells(1, iCol).Value = Sheet12.Range("A21") And Sheet12.Range("B21") = " " Then
total = total Cells(iRow, iCol).Value
End If
If Cells(1, iCol).Value = Sheet12.Range("A21") And Sheet12.Range("B21") = "-" Then
total = total - Cells(iRow, iCol).Value
End If
If Cells(1, iCol).Value = Sheet12.Range("A22") And Sheet12.Range("B22") = " " Then
total = total Cells(iRow, iCol).Value
End If
If Cells(1, iCol).Value = Sheet12.Range("A22") And Sheet12.Range("B22") = "-" Then
total = total - Cells(iRow, iCol).Value
End If
If Cells(1, iCol).Value = Sheet12.Range("A23") And Sheet12.Range("B23") = " " Then
total = total Cells(iRow, iCol).Value
End If
If Cells(1, iCol).Value = Sheet12.Range("A23") And Sheet12.Range("B23") = "-" Then
total = total - Cells(iRow, iCol).Value
End If
If Cells(1, iCol).Value = Sheet12.Range("A24") And Sheet12.Range("B24") = " " Then
total = total Cells(iRow, iCol).Value
End If
If Cells(1, iCol).Value = Sheet12.Range("A24") And Sheet12.Range("B24") = "-" Then
total = total - Cells(iRow, iCol).Value
End If
If Cells(1, iCol).Value = Sheet12.Range("A25") And Sheet12.Range("B25") = " " Then
total = total Cells(iRow, iCol).Value
End If
If Cells(1, iCol).Value = Sheet12.Range("A25") And Sheet12.Range("B25") = "-" Then
total = total - Cells(iRow, iCol).Value
End If
Next iCol
ws1.Cells(iRow, 1).Value = total
Next iRow
End Sub
如果需要更多資訊，請告訴我。
編輯：感謝@WojciechWojtulewski 的回答。以下是修改后的更新代碼，需要 10 分鐘而不是 25 分鐘才能完成。
Sub SumBasicPay()
Application.ScreenUpdating = False
Dim total As Double
Dim ws1 As Worksheet
Dim LastRow As Long
Set ws1 = ThisWorkbook.Worksheets("Main")
Worksheets("Database").Activate
LastRow = Range("A1").CurrentRegion.Rows.Count
For iRow = 2 To LastRow
total = 0
For iCol = 17 To 168
For abc = 7 To 25
If Cells(1, iCol).Value = Sheet12.Cells(abc, 1).Value And Sheet12.Cells(abc, 2) = " " Then
total = total Cells(iRow, iCol).Value
ElseIf Cells(1, iCol).Value = Sheet12.Cells(abc, 1).Value And Sheet12.Cells(abc, 2) = "-" Then
total = total - Cells(iRow, iCol).Value
End If
Next
Next iCol
ws1.Cells(iRow, 1).Value = total
Next iRow
End Sub
如果有人可以提供完成時間更少的陣列方法，那將不勝感激
uj5u.com熱心網友回復：
使用陣列總結
- 對于我的機器上的 50,000 條記錄（行），這需要 30 到 40 秒。
- 您還可以通過不檢查值是否為
Numeric（不推薦）來加速。
Option Explicit
Sub SumBasicPay()
' Source
Const sfRow As Long = 2
Const sfCol As Long = 17
Const slCol As Long = 168
' Lookup
Const lrgAddress As String = "A7:B25"
' Destination
Const dFirst As String = "A2"
' Workbook
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
' Source
Dim sws As Worksheet: Set sws = wb.Worksheets("Database")
Dim strg As Range: Set strg = sws.Range("A1").CurrentRegion
If strg.Columns.Count < slCol Then Exit Sub ' not enough columns
Dim rCount As Long: rCount = strg.Rows.Count - 1 ' source and destination
If rCount < 1 Then Exit Sub ' not enough rows
Dim srrg As Range: Set srrg = strg.Resize(rCount).Offset(1)
Dim scCount As Long: scCount = slCol - sfCol 1
Dim scrg As Range: Set scrg = sws.Columns(sfCol).Resize(, scCount)
Dim srg As Range: Set srg = Intersect(srrg, scrg)
Dim sData As Variant: sData = srg.Value
' Lookup
Dim lws As Worksheet: Set lws = Sheet12
Dim lrg As Range: Set lrg = lws.Range(lrgAddress)
Dim lrCount As Long: lrCount = lrg.Rows.Count
Dim lData As Variant: lData = lrg.Value
' Destination
Dim dws As Worksheet: Set dws = wb.Worksheets("Main")
Dim dfCell As Range: Set dfCell = dws.Range(dFirst)
Dim drg As Range: Set drg = dfCell.Resize(rCount)
Dim dData() As Double: ReDim dData(1 To rCount, 1 To 1)
' For...Next Loop Additional Variables
Dim sValue As Variant
Dim r As Long ' source and destination
Dim sc As Long
Dim lr As Long
Dim Total As Double
' Total
For r = 1 To rCount
Total = 0
For sc = 1 To scCount
For lr = 1 To lrCount
sValue = sData(r, sc)
If IsNumeric(sValue) Then ' is a number
If lData(lr, 1) = sValue Then ' is equal
Select Case CStr(lData(lr, 2))
Case " "
Total = Total sValue
Case "-"
Total = Total - sValue
'Case Else ' neither ' ' nor '-' (do nothing)
End Select
'Else ' is not equal (do nothing)
End If
'Else ' is not a number (do nothing)
End If
Next lr
Next sc
dData(r, 1) = Total
Next r
' Write
drg.Value = dData
MsgBox "Summed up Basic Pay.", vbInformation
End Sub
uj5u.com熱心網友回復：
For iRow = 2 To LastRow
total = 0
For iCol = 17 To 168
For iRow = 7 To 25
If Cells(1, iCol).Value = Sheet12.Celss(iRow, 1).Value And Sheet12.Cells(iRow, 2) = " " Then
total = total Cells(iRow, iCol).Value
Else
total = total - Cells(iRow, iCol).Value
End If
Next
Next iCol
ws1.Cells(iRow, 1).Value = total
Next iRow
轉載請註明出處，本文鏈接：https://www.uj5u.com/shujuku/370742.html