循环以检查单元格是否包含值，然后将其添加到另一个工作表中的单元格

Question

我试图仅为Level 1部分创建一个包含nom和max权重的摘要图表。所以我的代码读取第一张纸上的第1级列，如果级别= 1，则在第二张纸上打印偏移单元格值。我尝试打印主要部件名称，最大和标称重量，因为这些变化很多。但这不起作用。有什么想法吗？

这是我的Excel文件https://drive.google.com/file/d/0B1GLuBx-ROnhckdza1prZWo3YWM/edit?usp=sharing

到目前为止，这是我的代码

Sub trial()
    Dim ws1 As Worksheet, ws2 As Worksheet
    Dim Group As Range, Mat As Range
    Dim CurCell_1 As Range, CurCell_2 As Range

    Application.ScreenUpdating = False


    Set ws1 = Sheets("Major Assys")
    Set ws2 = Sheets("Summary")

    For Each Group In ws1.Range("B4:B200")
        Set CurCell_2 = ws1.Range("B6")
        For Each Mat In ws1.Range("B4:B200")
            Set CurCell_1 = ws1.Cells(Mat.Row, Group.Column)
            If CurCell_1 = 1 Then
            If Not IsEmpty(CurCell_1) Then
                CurCell_2.Value = CurCell_1.Value
                Set CurCell_2 = CurCell_2.Offset(1)
            End If
            End If
        Next
    Next

    Application.ScreenUpdating = True
End Sub

Answer 1

从您的屏幕截图中，此代码效果很好。

Sub MakeSummary()
    Dim oRng1 As Range, oRng2 As Range
    Dim oWS1 As Worksheet, oWS2 As Worksheet, i As Long

    ' Initial cell to check
    Set oWS1 = ThisWorkbook.Worksheets("Major Assys")
    Set oRng1 = oWS1.Range("A4")

    ' Initial cell to store
    Set oWS2 = ThisWorkbook.Worksheets("Summary")
    Set oRng2 = oWS2.Range("B6")

    ' Clear original data on Summary
    i = 0
    Do Until IsEmpty(oRng2.Offset(i, 0))
        oRng2.Offset(i, 0).EntireRow.ClearContents
        i = i + 1
    Loop

    ' Look for Level 1's on "Major Assys", then put in to "Summary"
    Do Until IsEmpty(oRng1)
        If oRng1.Value = 1 Then
            oRng2.Value = oRng1.Offset(0, 2).Value ' Description
            oRng2.Offset(0, 1).Value = oRng1.Offset(0, 3).Value ' Nominal
            oRng2.Offset(0, 2).Value = oRng1.Offset(0, 5).Value ' Max
            Set oRng2 = oRng2.Offset(1, 0) ' Move to next row to store
        End If
        Set oRng1 = oRng1.Offset(1, 0) ' Move to next row to check
    Loop

    ' Clean up
    Set oRng1 = Nothing
    Set oWS1 = Nothing
    Set oRng2 = Nothing
    Set oWS2 = Nothing
End Sub