1

この写真は、私が達成しようとしていることをほぼ教えてくれるはずだと思います。

私はまだ少し説明しようとすることができます。

私はトップテーブル5列ABCDEを持っています

列Aがメインで、最大8つのレコードを持つことができる個々の番号のレコードを含むNumが含まれています。

すべてのレコードをNUM単位で1行に入れる必要があります。

AとDでソートされます。

発生した時間に基づいて列Cを移動する必要があります。

最大8つの未作成レコードと最大4つの原因作成レコードを持つことができるため、列を追加しました。

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

4

1 に答える 1

1

私は次のことを想定しています

  1. 表1は、「入力」と呼ばれるシートにあります
  2. 出力は「出力」と呼ばれるシートに生成され、すでにヘッダーが配置されています

このコードをモジュールに貼り付けて実行します

Option Explicit

Sub Sample()
    Dim wsInput As Worksheet, wsOutput As Worksheet
    Dim wsILrow As Long, wsOLrow As Long, i As Long, c As Long, nc As Long
    Dim wsIrng As Range, fltrdRng As Range, cl As Range
    Dim col As New Collection
    Dim itm

    Set wsInput = Sheets("Input")
    Set wsOutput = Sheets("Output")

    With wsInput
        wsILrow = .Range("A" & .Rows.Count).End(xlUp).Row

        Set wsIrng = .Range("A1:E" & wsILrow)

        With wsIrng
            .Sort Key1:=.Range("A2"), Order1:=xlAscending, Key2:=.Range("D2") _
            , Order2:=xlAscending, Header:=xlYes, OrderCustom:=1, MatchCase:=False _
            , Orientation:=xlTopToBottom, DataOption1:=xlSortNormal, DataOption2:= _
            xlSortNormal
        End With

        For i = 2 To wsILrow
            On Error Resume Next
            col.Add .Cells(i, 1).Value, Chr(34) & .Cells(i, 1).Value & Chr(34)
            On Error GoTo 0
        Next i
    End With

    wsOLrow = 2

    With wsOutput
        For Each itm In col
            .Cells(wsOLrow, 1).Value = itm
            wsOLrow = wsOLrow + 1
        Next

        wsOLrow = .Range("A" & .Rows.Count).End(xlUp).Row

        For i = 2 To wsOLrow
            With wsInput
                '~~> Remove any filters
                .AutoFilterMode = False

                With wsIrng '<~~ Filter, offset(to exclude headers)
                    .AutoFilter Field:=1, Criteria1:=wsOutput.Cells(i, 1).Value
                    Set fltrdRng = .Offset(1, 0).SpecialCells(xlCellTypeVisible)
                End With

                '~~> Remove any filters
                .AutoFilterMode = False
            End With

            '<~~ c is for Cause column and nc is for non cause
            c = 3: nc = 7

            For Each cl In fltrdRng.Cells
                If cl.Column = 3 And Len(Trim(cl.Value)) <> 0 Then
                    If InStr(1, cl.Value, "Cause", vbTextCompare) Then
                        .Cells(i, c).Value = wsInput.Cells(cl.Row, 3).Value
                        c = c + 1
                    ElseIf InStr(1, cl.Value, "Non", vbTextCompare) Then
                        .Cells(i, nc).Value = wsInput.Cells(cl.Row, 3).Value
                        nc = nc + 1
                    End If

                    .Cells(i, 2).Value = wsInput.Cells(cl.Row, 2).Value
                    .Cells(i, 15).Value = wsInput.Cells(cl.Row, 5).Value
                End If
            Next
        Next i
    End With
End Sub

スクリーンショット

入力シート

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

出力シート

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

注：構造に対する将来の変更は、コードにも組み込む必要があります。

于 2013-02-20T20:07:10.470 に答える