我想编写一些VBA代码，该代码将计算工作表的单个列中有多少组“ T的连续行”。但是，我希望仅在包含 F 值的集合中最后 T 之后超过500行的情况下，才对此类数据集进行计数。例如，如果在行500-510处找到 T 值，则行511-1010必须包含 F 值才能将其添加到计数中。如果在到达1010之前遇到另一个T，则该代码将“重置” 500行计数器，然后重新开始。
row 1 - 1000 = F
row 1001 - 1011 = T
row 1012 - 1600 = F
row 1601 - 1611 = T
row 1612 - 3000 = F
在这种情况下，计数器将显示 2
相反：
row 1 - 1000 = F
row 1001 - 1011 = T
row 1012 - 1400 = F
row 1401 - 1411 = T
row 1412 - 3000 = F
该计数器将仅显示 1 ，因为群集1001-1011中的T小于群集1401-1411中的500行。
我还知道，在某些情况下，可能存在一组T，它们位于整体数据末尾的500行之内。这些也需要从计数中忽略（即，使用上面的示例，如果Ts发生在2,700-2710中，则在具有3,000行的数据集中，这些将需要从计数中忽略）。同样，我也需要从计数中排除1-500行。
我不知道这样做是否可行，甚至不知道如何开始编写代码，因此不胜感激。数据摘录：
F
F
F
F
F
F
F
F
F
T
T
T
T
T
F
F
F
F
F
F
F
F
这将被添加到一个更大的宏中，然后该宏将滤除所有包含Ts的行并将其删除。但是，我想在执行此步骤之前先执行连续T的计数。
其余宏的代码（此代码由另一个宏调用，该宏将生成的值粘贴到主文件中）
Sub RollMap_Ensocoat(Wb As Workbook)
Dim ws As Worksheet
Dim Rng As Range, Cell As Range
Dim finalRow As Long
'Set name of first sheet in spreadsheet to "1"
With Wb.Sheets(1)
.Name = "1"
End With
'Code to delete all rows that contain a "T" in column G" (Indicating a tab was fired and thus is waste)
With Sheets("1")
finalRow = .Range("G" & Rows.Count).End(xlUp).Row
.AutoFilterMode = False
With .Range("G4:G" & finalRow)
.AutoFilter Field:=1, Criteria1:="T"
.Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete
End With
.AutoFilterMode = False
'Code to calculate all the important values of each reel that will be pasted into the master report.
End With
Set ws = Wb.Sheets.Add(After:=Sheets(Wb.Sheets.Count))
With ws
.Range("A3").FormulaR1C1 = "=MAX('1'!C)"
.Range("B3").Formula = "=A3*I3"
.Range("C3").Formula = "=SUBTOTAL(109,'1'!B4:B10000)"
.Range("D3").Formula = "=SUBTOTAL(109,'1'!C4:C10000)"
.Range("E3").Formula = "=SUBTOTAL(109,'1'!D4:D10000)"
.Range("F3").Formula = "=SUBTOTAL(109,'1'!E4:E10000)"
.Range("G3").Formula = "=SUBTOTAL(109,'1'!F4:F10000)"
.Range("H3").Formula = "=SUM(C3:G3)"
.Range("I3").Formula = "='1'!A1"
.Range("J3").Formula = "=H3/(A3*I3)"
.Range("K3").Value = "0.21"
.Range("L3").Value = Wb.Name
.Range("M3").Formula = "=Left(L3, Len(L3) - 4)"
.Range("M3").Copy
.Range("M3").PasteSpecial xlPasteValues
.Range("N3").Formula = "=RIGHT(M3, 11)"
.Range("O3").Formula = "=LEFT(N3,2) & ""/"" & MID(N3,3,2) & ""/20"" & MID(N3,5,2)"
.Range("P3").Formula = "=MID(N3,8,2)& "":"" & MID(N3,10,2)"
.Range("Q3").Formula = "=Left(L3, Len(L3) - 16)"
.Range("A3:Q3").Copy
.Range("A3:Q3").PasteSpecial xlPasteValues
Application.CutCopyMode = False
.Range("A3:Q3").Copy
End With
End Sub
带有Tim建议添加的代码：
Sub Populate_Ensocoat()
On Error GoTo eh
Dim MyBook As String
Dim Wb As Workbook
Dim strFolder As String
Dim strFil As String
Dim StartTime As Double
Dim SecondsElapsed As Double
Dim xCount As Long
Dim SourceRang1 As Range
Dim FillRange1 As Range
'Code to improve performance
Application.ScreenUpdating = False
Application.EnableEvents = False
'Code to Prompt user to select file location
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False
.Show
strFolder = .SelectedItems(1)
Err.Clear
End With
'Code to count how many files are in folder and ask user if they wish to continue based on value counted
strFil = Dir(strFolder & "\*.csv*")
Do While strFil <> ""
xCount = xCount + 1
strFil = Dir()
Loop
If MsgBox("You have selected " & xCount & " files. Are you sure you wish to continue?", vbYesNo) = vbNo Then GoTo eh
'Code to Start timer
StartTime = Timer
'Code to make final report sheet visible and launch sheet hidden
Sheet1.Visible = True
Sheet1.Activate
Sheets("Sheet3").Visible = False
'declaring existing open workbook's name
MyBook = ActiveWorkbook.Name
'Code to cycle through all files in folder and paste values into master report
strFil = Dir(strFolder & "\*.csv*")
Do While strFil <> vbNullString
Set Wb = Workbooks.Open(strFolder & "\" & strFil)
Call RollMap_Ensocoat(Wb)
Workbooks(MyBook).Activate
ActiveSheet.Paste
Selection.HorizontalAlignment = xlCenter
ActiveCell.Offset(1).Select
Wb.Close SaveChanges:=False
strFil = Dir
Loop
'Formatting of values in final report
Range("B:I").NumberFormat = "#,##0"
Range("J:K").NumberFormat = "0.000"
Range("L:L").NumberFormat = "0.00"
Range("P:P").NumberFormat = "dd/MM/yyyy"
Range("Q:Q").NumberFormat = "hh:mm"
'Code to add header data to report (i.e. total files, name of person who created report, date and time report was created)
Range("Y2").Value = Now
Range("H2").Value = "# of Files Reported on: " & xCount
Range("P2").Value = Application.UserName
'Re-enabling features disabled for improved macro performance that are now needed to display finished report
Application.EnableEvents = True
Application.ScreenUpdating = True
'Code to refresh sheet so that graphs display properly
ThisWorkbook.RefreshAll
'Code to automatically save report in folder where files are located. Overrides warning prompting user that file is being saved in Non-macro enabled workbook.
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs Filename:=strFolder & "\" & "Summary Report", FileFormat:=xlOpenXMLWorkbook
Application.DisplayAlerts = True
'Code to display message box letting user know the number of files reported on and the time taken.
SecondsElapsed = Round(Timer - StartTime, 2)
MsgBox "Operation successfully performed on " & xCount & " files in " & SecondsElapsed & " seconds." & vbNewLine & vbNewLine & "Report created at location: " & Application.ActiveWorkbook.FullName, vbInformation
Done:
Exit Sub
eh:
MsgBox "No Folder Selected. Please select re-select a board grade"
End Sub
Sub RollMap_Ensocoat(Wb As Workbook)
Dim ws As Worksheet
Dim finalRow As Long
'Set name of first sheet in spreadsheet to "1"
With Wb.Sheets(1)
.Name = "1"
.Range("H1").Formula = "=TCount(G3:G10000)"
End With
'Code to delete all rows that contain a "T" in column G" (Indicating a tab was fired and thus is waste)
With Sheets("1")
finalRow = .Range("G" & Rows.Count).End(xlUp).Row
.AutoFilterMode = False
With .Range("G4:G" & finalRow)
.AutoFilter Field:=1, Criteria1:="T"
.Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete
End With
.AutoFilterMode = False
'Code to calculate all the important values of each reel that will be pasted into the master report.
End With
Set ws = Wb.Sheets.Add(After:=Sheets(Wb.Sheets.Count))
With ws
.Range("A3").FormulaR1C1 = "=MAX('1'!C)"
.Range("B3").Formula = "=A3*I3"
.Range("C3").Formula = "=SUBTOTAL(109,'1'!B4:B10000)"
.Range("D3").Formula = "=SUBTOTAL(109,'1'!C4:C10000)"
.Range("E3").Formula = "=SUBTOTAL(109,'1'!D4:D10000)"
.Range("F3").Formula = "=SUBTOTAL(109,'1'!E4:E10000)"
.Range("G3").Formula = "=SUBTOTAL(109,'1'!F4:F10000)"
.Range("H3").Formula = "=SUM(C3:G3)"
.Range("I3").Formula = "='1'!A1"
.Range("J3").Formula = "=H3/(A3*I3)"
.Range("K3").Value = "0.21"
.Range("L3").Value = Wb.Name
.Range("M3").Formula = "=Left(L3, Len(L3) - 4)"
.Range("M3").Copy
.Range("M3").PasteSpecial xlPasteValues
.Range("N3").Formula = "=RIGHT(M3, 11)"
.Range("O3").Formula = "=LEFT(N3,2) & ""/"" & MID(N3,3,2) & ""/20"" & MID(N3,5,2)"
.Range("P3").Formula = "=MID(N3,8,2)& "":"" & MID(N3,10,2)"
.Range("Q3").Formula = "=Left(L3, Len(L3) - 16)"
.Range("R3").Formula = "='1'!H1"
.Range("A3:R3").Copy
.Range("A3:R3").PasteSpecial xlPasteValues
Application.CutCopyMode = False
.Range("A3:R3").Copy
End With
End Sub
Function TCount(rng As Range)
Const GAP_SIZE As Long = 5 '<< low number for testing...
Dim rv As Long, i As Long, fCount As Long, n As Long, d
Dim haveT As Boolean
rv = 0
d = rng.Value
n = UBound(d, 1)
fCount = 0
If n > GAP_SIZE Then
For i = 1 To n
If d(i, 1) = "T" Then
fCount = 0
haveT = True
Else
fCount = fCount + 1
If fCount = GAP_SIZE And haveT Then
rv = rv + 1
haveT = False
End If
End If
Next i
End If
TCount = rv
End Function
答案 0 :(得分：0)
这样的事情。
如果我对您的规则有错误的假设，则可能需要调整。
Function TCount(rng As Range)
Const GAP_SIZE As Long = 5 '<< low number for testing...
Dim rv As Long, i As Long, fCount As Long, n As Long, d
Dim haveT As Boolean, earlyT as Boolean
rv = 0
d = rng.Value
n = UBound(d, 1)
fCount = 0
If n > GAP_SIZE Then
For i = 1 To n
If d(i, 1) = "T" Then
fCount = 0
If i <= GAP_SIZE Then earlyT = True '<<EDIT
haveT = True
Else
fCount = fCount + 1
If fCount = GAP_SIZE And haveT Then
rv = rv + 1
haveT = False
End If
End If
Next i
End If
TCount = rv - IIf(earlyT, 1, 0) '<< EDIT
End Function