Question

在Excel中创建宏不是我的强项，所以我想知道是否有人能够提供帮助。

我有一个包含产品值的小表，但不是每个单元都有值。我要做的是编写一个宏来在单独的工作表上创建一个列表。我写的宏适用于第一列，但这就是它停止的地方。

例如

List | aa | bb   | cc

a    |1   | 15   |  -

b    |2   | 23   | 12

c    |-   | 17   | 5

d    |4   | -    | -

应该出现在Sheet 2上，如此

- List| aa
- a   | 1
- b   | 2
- d   | 4
- List| bb
- a   | 15
- b   | 23
- c   | 17
- List| cc
- b   | 12
- c   | 5

目前，只有aa在第二张纸上正确显示，而没有其他列显示。

我到目前为止的宏是

Sub Button2_Click()
    Dim Column As Integer
    Column = 1
    newrow = 1
    Do Until Worksheets("Sheet1").Cells(Column, 1).Value = ""

        If Worksheets("Sheet1").Cells(Column, 2).Value <> "" Then

            Worksheets("Sheet2").Cells(newrow, 1).Value = Worksheets("Sheet1").Cells(Column, 1).Value
            Worksheets("Sheet2").Cells(newrow, 2).Value = Worksheets("Sheet1").Cells(Column, 2).Value

            newrow = newrow + 1
        End If
        Column = Column + 1
    Loop

End Sub

Answer 1

这就是我的建议。此代码示例基于以上示例数据。如果样本的结构发生变化，那么您必须相应地修改代码。我已经对代码进行了评论，因此您不应该在理解它时遇到问题。但如果你这样做，只需回复：）

<强> CODE

Option Explicit

Sub Sample()
    '~~> Input/Output Sheets
    Dim wsI As Worksheet, wsO As Worksheet
    Dim Lrow As Long, ORow As Long, i As Long
    Dim rngToFilter As Range

    '~~> Set the input, output sheets
    Set wsI = ThisWorkbook.Sheets("Sheet1")
    Set wsO = ThisWorkbook.Sheets("Sheet2")

    '~~> Set the output row in the new sheet
    ORow = 1

    With wsI
        '~~> Get last row in Col A
        Lrow = .Range("A" & .Rows.Count).End(xlUp).Row

        '~~> Set your range
        Set rngToFilter = .Range("A1:D" & Lrow)

        '~~> Hide Col C to E
        .Range("C:E").EntireColumn.Hidden = True

        '~~> Loop through Col B to Col D
        For i = 2 To 4

            '~~> Remove any filters
            .AutoFilterMode = False

            '~~> Copy Header viz List| aa, List| bb
            Union(.Cells(1, 1), .Cells(1, i)).Copy wsO.Range("A" & ORow)

            '~~> Get next empty row
            ORow = ORow + 1

            '~~> Filter, offset(to exclude headers) and copy visible rows
            With rngToFilter
                .AutoFilter Field:=i, Criteria1:="<>"

                '~~> Copy the filtered results to the new sheet
                .Offset(1, 0).SpecialCells(xlCellTypeVisible).Copy wsO.Range("A" & ORow)
            End With

            ORow = wsO.Range("A" & wsO.Rows.Count).End(xlUp).Row + 1

            '~~> Unhide/Hide relevant columns
            .Columns(i).EntireColumn.Hidden = True
            .Columns(i + 1).EntireColumn.Hidden = False

            '~~> Remove any filters
            .AutoFilterMode = False
        Next i

        '~~> Unhide all columns
        .Range("B:E").EntireColumn.Hidden = False
    End With
End Sub

<强> SCREENSHOT

enter image description here

创建Excel宏以填充值

1 个答案: