vba 创建 Excel 宏来填充值

Creating an Excel Macro to populate values

提问by Ian Baynham

Creating macros in Excel is not my strong point so I'm wondering if someone is able to help.

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

I have a small table with product values, though not every cell has a value. What I'm trying to do is write a macro to create a list on a separate sheet. The macro I have written works for the first column but that's where it stops.

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

For example

例如

List | aa | bb   | cc

a    |1   | 15   |  -

b    |2   | 23   | 12

c    |-   | 17   | 5

d    |4   | -    | -

Should appear on Sheet 2 like so

应该像这样出现在 Sheet 2 上

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

At the moment, only aa shows correctly on the 2nd sheet and none of the other columns.

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

The macro I have so far is

我到目前为止的宏是

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

回答by Siddharth Rout

This is what I was suggesting. This code sample is based on the above sample data. If the structure of the sample changes then you will have to amend the code accordingly. I have commented the code so that you shouldn't have a problem understanding it. But if you do, simply post back :)

这就是我所建议的。此代码示例基于上述示例数据。如果示例的结构发生变化，则您必须相应地修改代码。我已经对代码进行了注释，以便您理解它不会有问题。但如果你这样做，只需回发:)

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

截屏