我有一個關于在 VBA excel 中查找和檢測每行間隙的問題。困難的部分是從周五開始到周四的空檔 (FTGaps) 需要單獨累加，而從其他日子開始的空檔必須單獨計算。
因此，例如在圖片中，第一行的結果必須是：1 FTGap 和 1 Gap 第二行必須是 1 FTGap。
但是，如果該行前面有一個空單元格，則必須將其計為不同的間隙。因此，例如以下行輸出是 2 個間隙和 1 個 FTGap。
我希望我的問題很清楚。提前致謝
我試過的
For Row = 3 To Worksheets("Kalender2").UsedRange.Rows.Count
GapDays = 0
FTGapDays = 0
For col = 2 To 55 'Worksheets("Kalender2").Cells(2,
Columns.Count).End(xlToLeft).Column
If Worksheets("Kalender2").Cells(Row, col) = "0" And
Worksheets("Kalender2").Cells(2, col).Value = "Friday" Then
FTGapDays = FTGapDays 1
ElseIf Worksheets("Kalender2").Cells(Row, col) = "0" And
FTGapDays <> 0 Then
FTGapDays = FTGapDays 1 'doortellen gap startend op
vrijdag
ElseIf Worksheets("Kalender2").Cells(Row, col) = "0" And
FTGapDays = 0 Then 'And Worksheets("Kalender2").Cells(2, Col).Value <>
"Friday" Then
GapDays = GapDays 1 'eerste lege cel andere dag dan
vrijdag
End If
Next col
If col = 54 Then
Call EndGap
End If
呼叫 EndGap 下一行 '
然后是第二個 Sub Endgap()：
If FTGapDays <> 0 Then
If FTGapDays < 7 Then
If GapDays = 0 Then
Gaps = Gaps 1
End If
ElseIf FTGapDays >= 7 And FTGapDays < 14 Then
FTGaps = FTGaps 1
If GapDays = 0 Then
Gaps = Gaps 1
End If
ElseIf FTGapDays >= 14 And FTGapDays < 21 Then
FTGaps = FTGaps 2
If GapDays = 0 Then
Gaps = Gaps 1
End If
ElseIf FTGapDays >= 21 And FTGapDays < 28 Then
FTGaps = FTGaps 3
LegGaps = LegGaps 1
If GapDays = 0 Then
Gaps = Gaps 1
End If
ElseIf FTGapDays >= 28 And FTGapDays < 35 Then
FTGaps = FTGaps 4
LegGaps = LegGaps 1
If GapDays = 0 Then
Gaps = Gaps 1
End If
ElseIf FTGapDays >= 35 And FTGapDay < 42 Then
FTGaps = FTGaps 5
LegGaps = LegGaps 1
If GapDays = 0 Then
Gaps = Gaps 1
End If
ElseIf FTGapDays = 42 Then
FTGaps = FTGaps 6
LegGaps = LegGaps 2
End If
萬一
結束子
uj5u.com熱心網友回復：
請測驗下一個解決方案。它使用了一種技巧：在公式中將數字除以 0 將回傳錯誤。因此，這樣的公式被放置在最后兩行之后，然后使用SpecialCells(xlCellTypeFormulas, xlErrors)創建一個不連續的間隙范圍并對其進行處理。處理結果回傳最后一列右側的兩列。在第一個這樣的列中是“差距”，在第二個列中是“FTGap”。該代碼假定保留日期名稱的行是第二個，并且0圖片中看到的零 ( ) 不是您在代碼中嘗試使用的字串：
Sub extractGaps()
Dim sh As Worksheet, lastR As Long, lastCol As Long, rng As Range, arrCount, arrRows, i As Long
Set sh = ActiveSheet
lastR = sh.Range("A" & sh.rows.count).End(xlUp).row
lastCol = sh.cells(2, sh.Columns.count).End(xlToLeft).column
ReDim arrCount(1 To lastR - 2, 1 To lastCol)
Application.Calculation = xlCalculationManual: Application.ScreenUpdating = False
For i = 3 To lastR
arrRows = countGaps(sh.Range("A" & i, sh.cells(i, lastCol)), lastR, lastCol)
arrCount(i - 2, 1) = arrRows(0): arrCount(i - 2, 2) = arrRows(1)
Next i
sh.Range("A" & lastR 2).EntireRow.ClearContents
sh.cells(3, lastCol 2).Resize(UBound(arrCount), 2).value = arrCount
Application.Calculation = xlCalculationAutomatic: Application.ScreenUpdating = True
MsgBox "Ready..."
End Sub
Function countGaps(rngR As Range, lastR As Long, lastCol As Long) As Variant
Dim sh As Worksheet: Set sh = rngR.Parent
Dim rngProc As Range, i As Long, A As Range, FTGap As Long, Gap As Long, boolGap As Boolean, bigGaps As Double
Set rngProc = sh.Range(sh.cells(lastR 2, 1), sh.cells(lastR 2, lastCol)) 'a range where to place a formula returnig errors deviding by 0...
rngProc.Formula = "=1/" & rngR.Address
On Error Resume Next
Set rngProc = rngProc.SpecialCells(xlCellTypeFormulas, xlErrors)
On Error GoTo 0
If rngProc.cells.count = rngR.cells.count Then
If IsNumeric(rngProc.cells(1)) Then countGaps = Array(0, 0): Exit Function
End If
If rngProc Is Nothing Then countGaps = (0, 0): Exit Function 'in case of no gaps...???
Gap = 0: FTGap = 0
For Each A In rngProc.Areas
If A.cells.count < 7 Then
Gap = Gap 1
ElseIf A.cells.count = 7 Then
If sh.cells(2, A.cells(1).column).value = "Friday" Then
FTGap = FTGap 1
Else
Gap = Gap 1
End If
Else 'for more than 7 empty cells:
For i = 1 To A.cells.count
If sh.cells(2, A.cells(i).column).value = "Friday" Then
If boolGap Then Gap = Gap 1: boolGap = False
bigGaps = (A.cells.count - i 1) / 7
FTGap = FTGap Int(bigGaps)
If A.cells.count - i 1 - Int(bigGaps) * 7 > 0 Then Gap = Gap 1: Exit For
Else
boolGap = True
End If
Next i
End If
Next A
countGaps = Array(Gap, FTGap)
End Function
uj5u.com熱心網友回復：
問題
我們有一個范圍（顯然"B3:BC" & UsedRange.Rows.count）。該范圍前面有一行 ( B2:BC2)，其中包含按連續順序重復的星期幾：星期一、星期二等。
范圍內每一行的單元格包含一個0或其他一些值（整數？無關緊要）。連續0的 's in a row (length > 0) 被視為gap。我們有兩種型別的差距：
- a regular :任意長度 > 0
Gap的連續范圍；0 - 周五到周四的差距 (
FtGap)：一系列連續0的 ，從周五開始到周四結束（長度 = 7）。
對于每一行，我們要計算 and 的數量Gaps，FtGaps同時考慮以下條件：0符合 a條件的連續范圍FtGap不應也算作常規Gap。
解決方案
為了解決這個問題，我使用B3:BC20了資料范圍。0此范圍內的單元格已使用's 或1's（但此值可以是任何值）隨機填充=IF(RAND()>0.8,0,1)。我的“星期幾”的行以“星期一”開頭，但這應該沒有什么區別。
我使用了以下方法：
- 為行天數和資料創建兩個陣列。
- 通過 cols 使用嵌套回圈遍歷每個行陣列以訪問每行的所有單元格。
- 在每個 new
0上，將總計Gap數 (GapTrack) 增加 1。對于每個 new0，將一個變數 (GapTemp) 增加 1 以跟蹤Gap. 在下GapTemp一個非0. - 對于
0“星期五”的每一個，開始增加一個變數FtTemp。我們不斷檢查它的值（長度）是否達到了 7 的任意倍數。當它達到時，我們將Ftcount (FtTrack) 加 1。 - 在每個新的非
0上，檢查 ifFtTemp mod 7 = 0和GapTemp Mod 7 = 0 and GapTemp > 0。如果為 True，我們將在總計數中添加一個常規 Gap，其長度與一個或多個 相同FtTemps。這違反了上述條件。通過減GapTrack1 來解決此問題。 - 在行的末尾，我們包裝
GapTrack并FtTrack在一個陣列中，將其分配給字典中的一個新鍵。在下一行的開頭，我們重置所有變數，并重新開始計數。 - 回圈完成后，我們最終得到一個字典，其中包含每行的所有計數。我們將這些資料寫入某處。
代碼如下，并進一步說明正在發生的事情。注意我已經使用“選項顯式”來強制正確宣告我們所有的變數。
Option Explicit
Sub CountGaps()
Dim wb As Workbook
Dim ws As Worksheet
Set wb = ActiveWorkbook
Set ws = wb.Worksheets("Kalender2")
Dim rngDays As Range, rngData As Range
Dim arrDays As Variant, arrData() As Variant
Set rngDays = ws.Range("Days") 'Named range referencing $B$2:$BC$2 in "Kalender2!"
Set rngData = ws.Range("Data") 'Named range referencing $B$3:$BC$20 in "Kalender2!"
'populate arrays with range values
arrDays = rngDays.Value 'dimensions: arrDays(1, 1) to arrDays(1, rngDays.Columns.Count)
arrData = rngData.Value 'dimensions: arrData(1, 1) to arrData(rngData.rows.Count, rngData.Columns.Count)
'declare ints for loop through rows (i) and cols (i) of arrData
Dim i As Integer, j As Integer
'declare booleans to track if we are inside a Gap / FtGap
Dim GapFlag As Boolean, FtFlag As Boolean
'declare ints to track current Gap count (GapTemp), sum Gap count (GapTrack), and same for Ft
Dim GapTemp As Integer, GapTrack As Integer, FtTemp As Integer, FtTrack As Integer
'declare dictionary to store GapTrack and FtTrack for each row
'N.B. in VBA editor (Alt F11) go to Tools -> References, add "Microsoft Scripting Runtime" for this to work
Dim dict As New Scripting.Dictionary
'declare int (counter) for iteration over range to fill with results
Dim counter As Integer
'declare key for loop through dict
Dim key As Variant
'-----
'start procedure: looping through arrData rows: (arrData(i,1))
For i = LBound(arrData, 1) To UBound(arrData, 1)
'for each new row, reset variables to 0/False
GapTemp = 0
GapTrack = 0
GapFlag = False
FtTemp = 0
FtTrack = 0
FtFlag = False
'nested loop through arrData columns: (arrData(i,2))
For j = LBound(arrData, 2) To UBound(arrData, 2)
If arrData(i, j) = 0 Then
'cell contains 0: do stuff
If arrDays(1, j) = "Friday" Then
'Day = "Friday", start checking length Ft gap
FtFlag = True
End If
'increment Gap count
GapTemp = GapTemp 1
If GapFlag = False Then
'False: Gap was not yet added to Total Gap count;
'do this now
GapTrack = GapTrack 1
'toggle Flag to ensure continuance of 0 range will not be processed anew
GapFlag = True
End If
If FtFlag Then
'We are inside a 0 range that had a Friday in the preceding cells
'increment Ft count
FtTemp = FtTemp 1
If FtTemp Mod 7 = 0 Then
'if True, we will have found a new Ft Gap, add to Total Ft count
FtTrack = FtTrack 1
'toggle Flag to reset search for new Ft Gap
FtFlag = False
End If
End If
Else
'cell contains 1: evaluate variables
If (FtTemp Mod 7 = 0 And GapTemp Mod 7 = 0) And GapTemp > 0 Then
'if True, then it turns out that our last range STARTED with a "Friday" and continued through to a "Thursday"
'if so, we only want to add this gap to the Total Ft count, NOT to the Total Gap count
'N.B. since, in fact, we will already have added this range to the Total Gap count, we need to retract that step
'Hence: we decrement Total Gap count
GapTrack = GapTrack - 1
End If
'since cell contains 1, we need to reset our variables again (except of course the totals)
GapTemp = 0
GapFlag = False
FtTemp = 0
FtFlag = False
End If
Next j
'finally, at the end of each row, we assign the Total Gap / Ft counts as an array to a new key (i = row) in our dictionary
dict.Add i, Array(GapTrack, FtTrack)
Next i
'we have all our data now stored in the dictionary
'example of how we might write this data away in a range:
rngDays.Columns(rngData.Columns.Count).Offset(0, 1) = "Gaps" 'first col to the right of data
rngDays.Columns(rngData.Columns.Count).Offset(0, 2) = "FtGaps" 'second col to the right of data
'set counter for loop through keys
counter = 0
For Each key In dict.Keys
'resize each cell in first col to right of data to fit "Array(GapTrack, FtTrack)" and assign that array to its value ("dict(key)")
rngData.Columns(rngData.Columns.Count).Offset(counter, 1).Resize(1, 2).Value = dict(key)
'increment counter for next cell
counter = counter 1
Next key
End Sub
結果片段：
如果您在實施程序中遇到任何困難，請告訴我。
轉載請註明出處，本文鏈接：https://www.uj5u.com/caozuo/489357.html