Fatal编程技术网
  • vba/
  • Vba 如果500行内没有其他数据集出现，则对连续数据集进行计数

Vba 如果500行内没有其他数据集出现，则对连续数据集进行计数

vba

Vba 如果500行内没有其他数据集出现，则对连续数据集进行计数,vba,Vba,我想编写一些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 1

我想编写一些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中的Ts是类似的

如果我对你的规则做了错误的假设，你可能需要调整

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

功能t计数（rng As范围）
Const GAP_SIZE=5’GAP_SIZE
对于i=1到n
如果d（i，1）=“T”，那么
fCount=0

如果我所说的“集群”，你是指“连续的”——即一行中的几个T？你有代码吗？你能知道有多少个T在运行吗？T和F是唯一可能的值吗？有空白的单元格吗？我的意思是连续的。我已经包含了宏的代码，到目前为止，我已经为其他任务编写了宏代码，它已经执行得很好了。T和F是唯一可能的值。基本上，它们对应于一个软件输出的“真”和“假”状态。没有空白单元格。如果有一个不连续的Ts集合，但它们之间没有500个Fs，那么这算是0还是1？类似这样的内容：…FFFTTFFFTTTFFFF…Hello Caleb，使用您的示例，它将计为0。Hello Tim。谢谢你。我唯一的问题是，只有在同一工作簿中调用该函数时，我才能使它工作。目前我有一个主工作表，它调用上面的宏（RollMap_ensocat（）），然后获取宏生成的值，并将它们粘贴到主电子表格的下一行。我对自定义函数的记忆是模糊的，但我记不起是否可以调用一个函数，然后在另一个工作簿上使用它。它不是一个自定义函数-只需将现有VBA中的T/F值范围传递给它，然后使用返回值即可。Hello Tim。如果我创建一个新的工作簿，使用一个简单的子例程调用函数并返回一个基于我的范围的值，我就可以实现这个功能。我无法在我现有的VBA中使用#名称使其工作？当我尝试调用函数时返回。我在第一篇文章的末尾添加了完整的代码。#如果您通过VBA调用代码，则无法从该代码中获得名称：您是从工作表单元格中调用它的吗？您好Tim，调用函数还是个新手，但最终还是成功地使其工作了！使用以下代码使其正常工作：
Dim finalRow只要Dim作为整数Dim Rng作为Range finalRow=.Range（“G”和Rows.Count）。End（xlUp）。Row Set Rng=Range（“G4:G”和finalRow）Joins=TCount（Rng）。Range（“R3”）。Formula=Joins-1
感谢您的帮助。如果数组的前500行中存在一个T，是否有办法将函数从Tcount改为-1？

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



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



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