Question

请参阅下面的代码问题。提前谢谢

 Dim Acount As Long
Dim Bcount As Long
Dim Ccount As Long
Dim Dcount As Long
Dim Ecount As Long
Dim Fcount As Long
Dim Gcount As Long
Dim Hcount As Long
Dim Rcount() As Long
Dim Numrows As Long
Dim NamAry(1 To 7) As Variant
Dim SheetsVal(1 To 7) As Variant
Dim Pub(1 To 7) As Variant

    Workbooks.Open Filename:="N:\Desktop\Data.xlsx", ReadOnly:=True
    Sheets("Academy").Select
    ActiveSheet.Range("$A:$U").AutoFilter Field:=1, Criteria1:=Workbooks(Data2.xlsm).Worksheets("4.1").Range("$J$5"), Operator:=xlAnd
    Acount = ActiveSheet.AutoFilter.Range.Columns(1).SpecialCells(xlCellTypeVisible).Count - 1


    Sheets("Cambridge").Select
    ActiveWindow.SmallScroll Down:=-3
    ActiveSheet.Range("$A:$T").AutoFilter Field:=1, Criteria1:=Workbooks(Data2.xlsm).Worksheets("4.1").Range("$J$5"), Operator:=xlAnd
    Bcount = ActiveSheet.AutoFilter.Range.Columns(1).SpecialCells(xlCellTypeVisible).Count - 1


    Sheets("Brantford").Select
    ActiveSheet.Range("$A:$Q").AutoFilter Field:=1, Criteria1:=Workbooks(Data2.xlsm).Worksheets("4.1").Range("$J$5"), Operator:=xlAnd
    Ccount = ActiveSheet.AutoFilter.Range.Columns(1).SpecialCells(xlCellTypeVisible).Count - 1

    Sheets("Sherwood").Select
    ActiveSheet.Range("$A:$Q").AutoFilter Field:=1, Criteria1:=Workbooks(Data2.xlsm).Worksheets("4.1").Range("$J$5"), Operator:=xlAnd
    Dcount = ActiveSheet.AutoFilter.Range.Columns(1).SpecialCells(xlCellTypeVisible).Count - 1

    Sheets("KMY").Select
    ActiveSheet.Range("$A:$Y").AutoFilter Field:=1, Criteria1:=Workbooks(Data2.xlsm).Worksheets("4.1").Range("$J$5"), Operator:=xlAnd
    Ecount = ActiveSheet.AutoFilter.Range.Columns(1).SpecialCells(xlCellTypeVisible).Count - 1

    Sheets("Ship").Select
    ActiveSheet.Range("$A:$AA").AutoFilter Field:=1, Criteria1:=Workbooks(Data2.xlsm).Worksheets("4.1").Range("$J$5"), Operator:=xlAnd
    Fcount = ActiveSheet.AutoFilter.Range.Columns(1).SpecialCells(xlCellTypeVisible).Count - 1

    Sheets("PFS").Select
    ActiveSheet.Range("$A:$T").AutoFilter Field:=1, Criteria1:=Workbooks(Data2.xlsm).Worksheets("4.1").Range("$J$5"), Operator:=xlAnd
    Gcount = ActiveSheet.AutoFilter.Range.Columns(1).SpecialCells(xlCellTypeVisible).Count - 1

    Sheets("DUMP").Select
    ActiveSheet.Range("$A:$T").AutoFilter Field:=3, Criteria1:=Workbooks(Data2.xlsm).Worksheets("4.1").Range("$J$5"), Operator:=xlAnd
    Hcount = ActiveSheet.AutoFilter.Range.Columns(1).SpecialCells(xlCellTypeVisible).Count - 1


    'Sheets("Sheet9").Select
        'Range("A1").Select
        'NamAry = Array(Acount, Bcount, Ccount, Dcount, Ecount, Fcount)
   ' MsgBox NamAry()

NamAry(1) = Acount
NamAry(2) = Bcount
NamAry(3) = Ccount
NamAry(4) = Dcount
NamAry(5) = Ecount
NamAry(6) = Fcount
NamAry(7) = Gcount

SheetsVal(1) = "Academy"
SheetsVal(2) = "Cambridge"
SheetsVal(3) = "Brantford"
SheetsVal(4) = "Sherwood"
SheetsVal(5) = "KMY"
SheetsVal(6) = "Ship"
SheetsVal(7) = "PFS"


For INX = LBound(NamAry) To UBound(NamAry)
  Debug.Print NamAry(INX)
Next

For INX = 1 To 7
    If NamAry(INX) > 0 Then
        Pub(INX) = SheetsVal(INX)
    End If
Next

For INX = LBound(Pub) To UBound(Pub)
  Debug.Print Pub(INX)
Next

所以我得到了以下输出 13

0

4

12

0

1.Academy

2

3

4.KMY

5

6.Ship

7

我如何获得一个数组，让我们说Pub在这种情况下没有空格，这就是输出格式= pub = Array（“学院”，“KMY”，“船”）我需要在一组代码中使用它，但是无法解决这个问题。基本上我正在寻找一个带有基于自动过滤器结果的行＆gt; 0的工作表名称的连接数组

非常感谢任何帮助。

Answer 1

这种方法不会更好吗？

Sub CountNonZeroFilters()

Dim cl As Range
Dim output() As Variant
Dim i As Long
Dim sht As Worksheet

ReDim output(0 To 0)

'loop over all worksheets in book
For Each sht In ActiveWorkbook.Worksheets

    Select Case sht.Name

        'list all the sheets you want to check here
        Case "Academy", "Cambridge", "Brantford"

               'loop over cells in filter column
               For Each cl In sht.Range(sht.Range("A2"), sht.Range("A2").Offset(sht.Range("A2").CurrentRegion.Rows.Count, 0))

                    'if cell meets filter criteria add sheet name to array and go to next sheet
                    If cl.Value = Sheets("4.1").Range("J5").Value Then

                        ReDim Preserve output(0 To UBound(output) + 1)
                        output(i) = sht.Name
                        i = i + 1
                        GoTo nextSht

                    End If

                Next cl

        Case Else

            'do nothing

    End Select

nextSht:

Next sht


'test array

For i = 0 To UBound(output)

    Debug.Print output(i)

Next i

End Sub

使用工作表名称连接数组excel vba

1 个答案: