excel - すべての行を1つの見出しの下にグループ化するVBAマクロ、複数の見出しが存在する場合の見出し

Question

私は次のことを達成するためにvbaマクロを書いていますが、それを実装する方法はありません。ガイダンスを教えてください。

現在、データは次のとおりです（サブアイテムは列B以降にまたがっています）。

ITEM ONE [Subitem one... ]
ITEM ONE [Subitem two ...]
ITEM ONE [Subitem three...]  
ITEM TWO [Subitem one  ...]
ITEM THREE [Subitem one...]
ITEM Three [Subitem two...]

別のシートでデータがどのように表示されるかを次に示します。

ITEM ONE  
-------- 
Subitem one  
Subitem two 
Subitem three  

ITEM TWO 
-------- 
Subitem one  

ITEM THREE 
---------- 
Subitem one 
Subitem two

任意のガイダンス/ヘルプは大歓迎です。

編集：次のような解決策：

  r = Range("a65536").End(xlUp).Row
  c = Range("IU1").End(xlToLeft).Column
  a = Split(Cells(, c).Address, "$")(1)
  MsgBox "last row with data is " & r & " and last column with data is " & a & "", vbOKOnly, "LastRow and LastCol"
  rr = r + 1

  Application.Visible = False

  Range("A1:" & a & r & "").Sort Key1:=Range("B2"), Order1:=xlAscending, Header:= _
    xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
    DataOption1:=xlSortNormal

Sheets("owssvr(1)").Select
Sheets.Add


'by default select first record and paste in reports sheet
Sheets("owssvr(1)").Select
Range("b2").Select
Selection.Copy

Sheets(1).Select
Range("b2").Select
ActiveSheet.Paste

   'paste header below it

Sheets("owssvr(1)").Select
Range("c1:" & a & "2").Select
Selection.Copy

Sheets(1).Select
Range("b3").Select
ActiveSheet.Paste



For i = 3 To r
Sheets(2).Select
'Program name is same as above, dont copy name but row starting from next col, switch to other sheet, find last row in col B, add one to last row and paste
    If Cells(i, 2).Value = Cells(i - 1, 2) Then
        Range("C" & i & ":" & a & i & "").Select
        Selection.Copy

        Sheets(1).Select
        'Range("b3").Select
        lr2 = Range("b65536").End(xlUp).Row
        Range("B" & lr2 + 1 & "").Select
        ActiveSheet.Paste
        Else
        'if name is not same as above, copy name, find last row, add two to add a gap from prev program name, paste program name, move to next row and paste remaining cols
         Sheets(2).Select
         Range("B" & i & "").Select
         Selection.Copy

         Sheets(1).Select
         lr2 = Range("b65536").End(xlUp).Row
         Range("B" & lr2 + 2 & "").Select
         ActiveSheet.Paste

         'copy headers
         Sheets(2).Select

         Range("c1:" & a & "1").Select
         Selection.Copy
         Sheets(1).Select
         lr2 = Range("b65536").End(xlUp).Row
         Range("B" & lr2 + 1 & "").Select
         ActiveSheet.Paste

         'copy cells(row, col+1)
         Sheets(2).Select
         Range("C" & i & ":" & a & i & "").Select
         Selection.Copy

         Sheets(1).Select
        'Range("b3").Select
         lr2 = Range("b65536").End(xlUp).Row
         Range("B" & lr2 + 1 & "").Select
         ActiveSheet.Paste

    End If
    Next

score 1 · Accepted Answer

あなたが求めていることは、PivotTableで行うことができます。私は Excel 2010 で作業していますが、2003 でもおそらく同じ機能を持つはずです。これはどのように見えるかです。

ソースデータ

ピボットテーブル

私がやろうとしていた単純な VBA アプローチ (あなたが実装したと思います) は、すべてのアイテムをループし、比較を行い、一度に 1 つずつ新しいワークシートに追加することでした。最初の範囲 (2 列) を配列に格納し、それをループして出力を 2 番目の配列に格納し、配列を範囲にコピーして戻すと、これを少し効率的にすることができます。

データの量や操作にかかる時間はわかりません。もう 1 つの方法は、マクロレコーダーを使用してピボットテーブルを作成し、そこからデータを新しいシートにコピーすることです。以下に例を示しますが、ワークシートと範囲参照を変更して明示的/動的にする必要があります。例のデータ範囲はA1:B9.

Sub Example()

    Range(Selection, Selection.End(xlToRight)).Select
    Range(Selection, Selection.End(xlDown)).Select

    Sheets.Add
    ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:= _
        "Sheet1!R1C1:R9C2", Version:=xlPivotTableVersion14).CreatePivotTable _
        TableDestination:="Sheet4!R3C1", TableName:="PivotTable1", DefaultVersion _
        :=xlPivotTableVersion14
    Sheets("Sheet4").Select
    Cells(3, 1).Select
    With ActiveSheet.PivotTables("PivotTable1").PivotFields("item1")
        .Orientation = xlRowField
        .Position = 1
    End With
    With ActiveSheet.PivotTables("PivotTable1").PivotFields("sub12")
        .Orientation = xlRowField
        .Position = 2
    End With
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Copy
    Sheets("Sheet2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
End Sub

score 0 · Accepted Answer

Sub Sort1()
'
' Sort1 Macro
' Macro recorded 7/30/2012 by American International Group
'
'

Dim r As Integer
Dim c As Integer
Dim lr2 As Integer
Dim a As String
Dim b As String
Dim cdb As Long
Dim name1 As String
Dim name2 As String


n1 = InputBox(Prompt:="Enter a name for worksheet else click OK", Title:="Enter a name for this sheet", Default:="owssvr")
n2 = InputBox(Prompt:="Enter a name for the Report view sheet else click OK", Title:="Enter a name for Report sheet", Default:="reportView")
b = InputBox(Prompt:="Enter Column Name on which to sort data", Title:="Sort by", Default:="B")
b = UCase(b)   'convert to uppercase  e.g.c to C
asciiCol = Asc(b)   'convert to ascii          66
asciiNext = asciiCol + 1  'add one to ascii to get next column ascii code e.g. 66+1=67 to get D


sortbyColNo = 0
sortbyColNo = Range(b & "1").Column

'Rename sheets to avoid conflict
Sheets(1).name = n1

Sheets("" & n1 & "").Select

r = Range("a65536").End(xlUp).Row
c = Range("IU1").End(xlToLeft).Column
a = Split(Cells(, c).Address, "$")(1)
x = Split(Cells(, c).Address, "$")(2)
MsgBox "last row with data is " & r & " and last column with data is " & a & "", vbOKOnly, "LastRow and LastCol"
rr = r + 1

'Application.Visible = False

  Range("A1:" & a & r & "").Sort Key1:=Range("" & b & "2"), Order1:=xlAscending, Header:= _
    xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
    DataOption1:=xlSortNormal

   Sheets("" & n1 & "").Select
Sheets.Add
ActiveSheet.name = n2

'by default select first record and paste in reports sheet
Sheets("" & n1 & "").Select
Range("" & b & "2").Select
Selection.Copy

Sheets("" & n2 & "").Select
Range("b2").Select
ActiveSheet.Paste

'paste header below it

Sheets("" & n1 & "").Select
Range("" & Chr(asciiNext) & "1:" & a & "1").Select
With Selection
.Font.Bold = True
End With
Range("" & Chr(asciiNext) & "1:" & a & "2").Select
Selection.Copy

Sheets("" & n2 & "").Select
Range("b3").Select
ActiveSheet.Paste


'start from row 3
For i = 3 To r
  Sheets("" & n1 & "").Select
'Program name is same as above, dont copy name but row starting from next col, switch to other sheet, find last row in col B, add one to last row and paste
    If Cells(i, sortbyColNo).Value = Cells(i - 1, sortbyColNo) Then
        Range("" & Chr(asciiNext) & "" & i & ":" & a & i & "").Select
        Selection.Copy

        Sheets("" & n2 & "").Select
        'Range("b3").Select
        lr2 = Range("b65536").End(xlUp).Row
        Range("B" & lr2 + 1 & "").Select
        ActiveSheet.Paste
        Else
        'if name is not same as above, copy name, find last row, add two to add a gap from prev program name, paste program name, move to next row and paste remaining cols
        Sheets("" & n1 & "").Select
         Range("" & b & "" & i & "").Select
         Selection.Copy

       Sheets("" & n2 & "").Select
         lr2 = Range("b65536").End(xlUp).Row
         Range("B" & lr2 + 2 & "").Select
         ActiveSheet.Paste

         'copy headers
        Sheets("" & n1 & "").Select

         Range("" & Chr(asciiNext) & "1:" & a & "1").Select
         Selection.Copy
       Sheets("" & n2 & "").Select
         lr2 = Range("b65536").End(xlUp).Row
         Range("B" & lr2 + 1 & "").Select
         ActiveSheet.Paste

         'copy cells(row, col+1)
     Sheets("" & n1 & "").Select
         Range("" & Chr(asciiNext) & i & ":" & a & i & "").Select
         Selection.Copy

        Sheets("" & n2 & "").Select
        'Range("b3").Select
         lr2 = Range("b65536").End(xlUp).Row
         Range("B" & lr2 + 1 & "").Select
         ActiveSheet.Paste

    End If
    Next
 'Application.Visible = True

'formatSheet

End Sub

score 0 · Accepted Answer

古いワークシートはyourWorksheetと呼ばれます。新しいワークシートを作成します。

set newWS = thisworkbook.workbooks.add()

dim rr as long 
rr =1

for r = startRow to yourWorksheet.UsedRange.Rows.Count
    firstItem = yourWorksheet.cells(r,1).value
    newWS.cells(rr,1).value = firstItem
    rr = rr + 1
    do while firstItem = yourworksheet.cells(r,1).value
       newWS.cells(rr,1).value = yourworksheet.cells(rr,2).value 'copy all columns here
       rr = rr + 1
       r =r + 1
    loop
next r

ラフでテストされていませんが、それがアイデアです。

score 0 · Accepted Answer

左のコマンドを使用して、アイテム 1、アイテム 2 などを抽出すると、

Heading(row) = Left(Cells(row,"B"), 8)

次にサブアイテムを抽出します。

SubItem(row) = Left(Right(cells(row, "B"), 20), 10)

これらはテキストを抽出します。

THREE と FOUR のためにクリエイティブにならなければなりません。

excel - すべての行を1つの見出しの下にグループ化するVBAマクロ、複数の見出しが存在する場合の見出し

4 に答える 4

Related

Reference