0

基準に基づいてシート 1 からシート 2 までの行を一覧表示し、最初の基準に従ってコピーする行がなくなったら次の基準に進み、コピーされた行をヘッダーで区切ります。

Sheet1 にはプロジェクトの並べ替えられていないリストが含まれており、いつでもプロジェクトを追加および削除できるようにしたいと考えています。また、プロジェクトをさまざまなタイプに分類したいと考えています。Sheet1 は次のようになります。

ProjectID ProjectName タイプ コスト
1 ProjectA 開発 -120
2 ProjectB 開発 -250
3 ProjectC メンテナンス -30

次に、VBA 経由でデータを次の形式で Sheet2 にコピーしたいと思います。

メンテナンスプロジェクト
ProjectID ProjectName タイプ コスト
3 ProjectC メンテナンス -30

開発プロジェクト
ProjectID ProjectName タイプ コスト
1 ProjectA 開発 -120
2 ProjectB 開発 -250

私は解決策を探していましたが、私のニーズに合った解決策が見つかりませんでした。私は経験豊富な VBA ユーザーではありません。ここで使用する方法に関するヒントやヒントはありますか?

4

1 に答える 1

0

これにより、シート 2 が要求した形式で空白であると仮定して、データがシート 1 からシート 2 にコピーされます。

Sub SplitData_Click()
    Dim dicType As Object
    Set dicType = CreateObject("scripting.dictionary")

    Dim i As Integer
    Dim lstRow As Long
    Dim val As String
    lstRow = ActiveSheet.Cells(ActiveSheet.Rows.Count, 4).End(xlUp).Row

    Dim projects() As Variant
    ReDim projects(0 To lstRow - 2, 0 To 3) ' I like 0 based arrays

    ' Populate the dictionary with the unique types
    For i = 2 To lstRow
        projects(i - 2, 0) = Range("A" & i) ' ProjectID
        projects(i - 2, 1) = Range("B" & i) ' ProjectName
        projects(i - 2, 2) = Range("C" & i) ' Type
        projects(i - 2, 3) = Range("D" & i) ' Cost

        val = Range("C" & i)
        If dicType.Exists(val) Then
            dicType.Item(val) = dicType.Item(val) + 1
        Else
            dicType.Add val, 1
        End If
    Next i

    Dim header() As Variant
    ReDim header(0 To 3)
    header(0) = "ProjectId"
    header(1) = "ProjectName"
    header(2) = "Type"
    header(3) = "Cost"

    Sheets("Sheet2").Select

    ' loop through each type and build its structure on sheet 2
    Dim key As Variant
    For Each key In dicType
        If Range("A1") = "" Then
            Range("A1").Value = key & " Projects"
        Else
            lstRow = ActiveSheet.Cells(ActiveSheet.Rows.Count, 1).End(xlUp).Row + 2
            Range("A" & lstRow).Value = key & " Projects"
        End If

        lstRow = ActiveSheet.Cells(ActiveSheet.Rows.Count, 1).End(xlUp).Row + 1
        Range("A" & lstRow).Value = header(0)
        Range("B" & lstRow).Value = header(1)
        Range("C" & lstRow).Value = header(2)
        Range("D" & lstRow).Value = header(3)

        For i = 0 To UBound(projects)
            lstRow = ActiveSheet.Cells(ActiveSheet.Rows.Count, 1).End(xlUp).Row + 1
            If projects(i, 2) = key Then
                Range("A" & lstRow).Value = projects(i, 0)
                Range("B" & lstRow).Value = projects(i, 1)
                Range("C" & lstRow).Value = projects(i, 2)
                Range("D" & lstRow).Value = projects(i, 3)
            End If
        Next i

        Debug.Print key
    Next key
End Sub
于 2013-03-05T20:38:45.143 に答える