需要帮助从“是”和“否”矩阵创建将行转换为工作表的宏

Question

我正在寻找在 VBA 中的宏的帮助下，将我的 Yes & No 矩阵转换为 excel 工作簿中的单独工作表选项卡。

所以我有 B1 到 Z1 列以设备命名，A2 到 A50 列以测试命名。 B2至Z50区域根据测试和设备要求填充Y和N。

我正在寻找的是，是否有任何方法可以使用宏将数据拆分为带有设备名称的表格，并且每张表格将仅包含矩阵中标记为 Y 的那些测试的名称。

示例矩阵

我是 VBA 的新手，通过查看 intermate 上可用的资源进行了几次尝试，但到目前为止还没有运气。 寻找你的帮助！

Answer 1

试试这个代码：

Option Explicit

Sub splitEq()
    Dim ws As Worksheet, dataArea As Range, rng As Range, cl As Range
    
    Const DATA_SHEET_NAME = "DataSheet" ' DataSheet into Worksheets("DataSheet") with the name of your own worksheet with data
    Const ANCHOR = "H16" 'cell address within data range
    
    Application.ScreenUpdating = False  ' speed up script working
    
    With ThisWorkbook.Worksheets(DATA_SHEET_NAME)
        Set dataArea = .Range(ANCHOR).CurrentRegion
        
        For Each cl In Intersect(dataArea(1).EntireRow, .UsedRange, .UsedRange.Offset(0, 1)) ' skip rows names column
            
            dataArea.AutoFilter   ' set initial filter or reset previous filter
            dataArea.AutoFilter Field:=cl.Column - dataArea(1).Column + 1, Criteria1:="Y"
            
            ' select only visible cells after filter apply and get rows names at rows where these cells are is
            Set rng = Intersect( _
                Intersect(cl.EntireColumn, .UsedRange) _
                .SpecialCells(xlCellTypeVisible) _
                .EntireRow, .Columns(dataArea(1).Column))
            
            If rng.Cells.Count > 1 Then  ' rng contains not only header
                Set ws = ThisWorkbook.Worksheets.Add
                ws.Move After:=ThisWorkbook.Worksheets( _
                    ThisWorkbook.Worksheets.Count) ' move the ws to the end
                ws.Name = cl    ' set the ws name
                rng.Copy ws.Range("A1")
            End If
        Next
        .AutoFilterMode = False     ' switch off the filter
    End With
    Application.ScreenUpdating = True
End Sub