3

Excelでマクロを作成することは私の強みではないので、誰かが助けてくれるかどうか疑問に思っています。

すべてのセルに値があるわけではありませんが、製品の値を含む小さなテーブルがあります。私がやろうとしているのは、別のシートにリストを作成するためのマクロを書くことです。私が書いたマクロは最初の列で機能しますが、そこで止まります。

例えば

List | aa | bb   | cc

a    |1   | 15   |  -

b    |2   | 23   | 12

c    |-   | 17   | 5

d    |4   | -    | -

そのようにシート2に表示されるはずです

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

現時点では、aaのみが2枚目のシートに正しく表示され、他の列には表示されません。

私が今まで持っているマクロは

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
4

1 に答える 1

4

これが私が提案していたことです。このコードサンプルは、上記のサンプルデータに基づいています。サンプルの構造が変更された場合は、それに応じてコードを修正する必要があります。あなたがそれを理解するのに問題がないように、私はコードにコメントしました。しかし、そうする場合は、単に投稿してください:)

コード

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

スクリーンショット

ここに画像の説明を入力してください

于 2012-10-25T17:45:35.460 に答える