使用过滤器选项移动数据输入-Movingdataentrywithfilteroptions

First off prepare for a long read, I've narrowed down the info as much as I could.

首先准备长时间阅读,我尽可能地缩小信息范围。

So I am using VBA since a little while now and I've encountered a problem which I can not seem to solve. I'm using a code in VBA to do the following: Sheet "Two" contains multiple rows of data sets. These data sets can be filtered using dropdown menus in the first row of the sheet. I've set up a macro to check if the necessary data sets are present, which can be checked for by seeing if there is text present in certain rows. If there is text then a corresponding box is filled and colored accordingly, the same applies if data is missing. After the loop is completed it counts a summary of the cells with all data and with missing data an fills this in an overview on Sheet "One".

所以我现在使用VBA一段时间了,我遇到了一个我似乎无法解决的问题。我在VBA中使用代码来执行以下操作:工作表“Two”包含多行数据集。可以使用工作表第一行中的下拉菜单过滤这些数据集。我已经设置了一个宏来检查是否存在必要的数据集,可以通过查看某些行中是否存在文本来检查。如果有文本,则相应的框被填充并相应地着色,如果缺少数据则同样适用。循环完成后,它会计算包含所有数据和缺失数据的单元格摘要,并在Sheet“One”的概述中填写。

When the code needs to run for the entire column to check data in, it will do so without problems. However when a filter is selected the code does no start at the filtered selection, instead it starts at the second cell in the column. It does because I defined the second cell as the starting point. I cannot figure out however how to define the starting point in such a dynamic way that it will follow with the filter settings. Furthermore the code does not compensate for "gaps" (e.g. when the filter settings make the row jump from row 5 to row 30, the code will keep counting on from 5, it does not jump along so to speak). As the data sets can number up to around 150.000 a lot of gaps can be present, so this cripples the code heavily. See my code below.

当代码需要为整个列运行以检查数据时,它会毫无问题地这样做。但是,当选择过滤器时,代码不会从过滤的选择开始,而是从列中的第二个单元格开始。这样做是因为我将第二个单元格定义为起点。然而,我无法弄清楚如何以一种动态的方式定义起点,它将遵循过滤器设置。此外,代码不补偿“间隙”(例如,当滤波器设置使行从第5行跳到第30行时,代码将从5开始依次计数,它不会跳过这样说)。由于数据集的数量可以达到150,000左右,因此可能存在很多差距,因此这会严重影响代码。请参阅下面的代码。

    Sub CompletionStatusUpdate()

    Dim CompletionStatus As Range 'Creates list to check for Completion Status
    Dim DataGetCompletion As Long 'Defines counter to determine maximum list limit to check

    ThisWorkbook.Sheets("Two").Range("H2:H" & ThisWorkbook.Sheets("One").Range("H9").Value).Interior.ColorIndex = 0 'Reset Colors in 2nd Tab for Completion Status
    ThisWorkbook.Sheets("Two").Range("H2:H" & ThisWorkbook.Sheets("One").Range("H9")).Value = "" 'Reset Values in 2nd Tab for Completion Status  
    'Cell H9 in Sheet One contains a CountA function which checks the amount of data present in Sheet Two. Right now it counts the entire amount of data in row C, 
    'however this needs to be adjusted to only count the cells of data which are filtered in row C

    For Each CompletionStatus In ThisWorkbook.Sheets("Two").Range("H2:H" & ThisWorkbook.Sheets("One").Range("H9").Value + 1) 
    'Creates loop for cells that need to be filled/colored
    'This needs to run over only the filtered cells in the selection
    'Instead of over the H column untill H9 value is reached regardles of filters

    DataGetCompletion = (DataGetCompletion + 1) 'DataGetCompletion Counter for Range, used to move the position of cells to fill in

    ThisWorkbook.Sheets("One").Range("H6").Value = DataGetCompletion + 2 'Ticks up for each loop run through, corrected for the starting cell
    'Again this needs adjust dependant on the filter settings

    If ThisWorkbook.Sheets("Two").Range("D" & ThisWorkbook.Sheets("One").Range("H9")).Value = "Yes" And _
       ThisWorkbook.Sheets("Two").Range("F" & ThisWorkbook.Sheets("One").Range("H9")).Value = "Yes" Then 
       ThisWorkbook.Sheets("One").Range("H8").Value = 1 'Both Data sets are present,used in separate logic
    End If 'This needs to check only filtered cells as well, instead of all cells

    If ThisWorkbook.Sheets("Two").Range("D" & ThisWorkbook.Sheets("One").Range("H9")).Value = "No" And _
       ThisWorkbook.Sheets("Two").Range("F" & ThisWorkbook.Sheets("One").Range("H9")).Value = "No" Then 
       ThisWorkbook.Sheets("One").Range("H8").Value = 0 'Both data sets missing, used in separate logic
    End If 'This needs to check only filtered cells as well, instead of all cells

    If ThisWorkbook.Sheets("One").Range("H8") = 0 Then 'Both data sets missing, so problem
       CompletionStatus.Interior.ColorIndex = 3 'Colors cell red
       CompletionStatus.Value = "Both data sets missing" 'Displays missing information
    End If

    If ThisWorkbook.Sheets("One").Range("H8") = 1 Then 'Data sets complete
       CompletionStatus.Interior.ColorIndex = 4 'Colors cell green
       CompletionStatus.Value = "Both data sets complete" 'Displays completion
    End If

    Next CompletionStatus 'Reruns loop till completion

    ThisWorkbook.Sheets("One").Range("H11").Value = Application.WorksheetFunction.CountIf _
    (ThisWorkbook.Sheets("Two").Range("H2:H" & ThisWorkbook.Sheets("One").Range("H9").Value + 1), "Both data sets complete")

    'Displays amount of complete data sets 
    'This part of the code also needs to run over the filtered selection in the H column, instead of starting from H2 and running till value Sheet One, H9 is reached

    ThisWorkbook.Sheets("One").Range("H13").Value = Application.WorksheetFunction.CountIf _
    (ThisWorkbook.Sheets("Two").Range("H2:H" & ThisWorkbook.Sheets("One").Range("H9").Value + 1), "Both data sets missing")

    'Displays amount of missing data sets
    'This part of the code also needs to run over the filtered selection in the H column, instead of starting from H2 and running till value Sheet One, H9 is reached

     End Sub

I just cant seem to get it to work with the filters, I've tried different applications of the .SpecialCells(xlCellTypeVisible) code but it didn't help me.

我似乎无法使用过滤器,我尝试过.SpecialCells(xlCellTypeVisible)代码的不同应用程序,但它没有帮助我。

Any Help would be greatly appreciated, if something is not clear please let me know.

非常感谢任何帮助,如果不清楚,请告诉我。

1 个解决方案

 For Each CompletionStatus In loopRange

        If CompletionStatus.EntireRow.Hidden = False Then

            Select Case h8Range

            Case 1 'this was 1 in yours

                CompletionStatus.Interior.ColorIndex = 4
                CompletionStatus.Value = "Both data sets complete"

            Case 2 'this was 0 in yours

                CompletionStatus.Interior.ColorIndex = 3
                CompletionStatus.Value = "Both data sets missing"

            End Select

        End If

    Next CompletionStatus

Option Explicit

Sub CompletionStatusUpdate()

    Dim CompletionStatus As Range
    Dim wb As Workbook
    Set wb = ThisWorkbook
    Dim ws1 As Worksheet
    Set ws1 = wb.Sheets("One")
    Dim ws2 As Worksheet
    Set ws2 = wb.Sheets("Two")

    Dim h9Range As Range
    Set h9Range = ws1.Range("H9")

    'Test for h9Range being not empty and that is greater than 2?
    ws2.Range("H2:H" & h9Range.Value + 1).Interior.ColorIndex = 0 'if this is intended to clear prior runs it needs + 1
    ws2.Range("H2:H" & h9Range.Value + 1).ClearContents 'This seems to be the same as loopRange?

    Dim completeRange As Range
    Set completeRange = ws1.Range("H11")

    Dim missingRange As Range
    Set missingRange = ws1.Range("H13")

    missingRange.ClearContents
    completeRange.ClearContents

    Dim h8Range As Range
    Set h8Range = ws1.Range("H8")

    Dim dRange As Range
    Set dRange = ws2.Range("D" & h9Range.Value)

    Dim fRange As Range
    Set fRange = ws2.Range("F" & h9Range.Value)

    Dim countRange As Range
    Set countRange = ws2.Range("H2:H" & h9Range.Value + 1)

    Dim h6Range As Range
    Set h6Range = ws1.Range("H6")

    Dim loopRange As Range

    Set loopRange = ws2.Range("H2:H" & h9Range.Value + 1).SpecialCells(xlCellTypeVisible)

    DataGetCompletion = 3


    If dRange = "Yes" And fRange = "Yes" Then

        h8Range = 1

    ElseIf dRange = "No" And fRange = "No" Then

        h8Range = 2

    Else

        h8Range = 3

    End If


    For Each CompletionStatus In loopRange

        If CompletionStatus.EntireRow.Hidden = False Then

            Select Case h8Range

            Case 1

                CompletionStatus.Interior.ColorIndex = 4
                CompletionStatus.Value = "Both data sets complete"

            Case 2

                CompletionStatus.Interior.ColorIndex = 3
                CompletionStatus.Value = "Both data sets missing"

            End Select

        End If

    Next CompletionStatus


    completeRange = Application.WorksheetFunction.CountIf _
                    (countRange, "Both data sets complete")

    missingRange = Application.WorksheetFunction.CountIf _
                   (countRange, "Both data sets missing")

End Sub