VBA 宏将所有行分组到一个标题下，存在多个标题时的标题

VBA macro to group all rows under one heading, headings when more than one heading exists

提问by joiner

I am writing a vba macro to achieve the following but do not how to implement it. Would any please provide some guidance?

我正在编写一个 vba 宏来实现以下功能，但不知道如何实现它。任何人都可以提供一些指导吗？

Currently, the data is as follows(subitem spans from column B onwards):

目前，数据如下（子项从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...] 

The following is what the data should look like in a separate sheet:

以下是数据在单独的工作表中的样子：

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

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

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

Any guidance/help will be greatly appreciated.

任何指导/帮助将不胜感激。

Edited: solution as follows:

编辑：解决方案如下：

  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

回答by Zairja

What you're asking for can be done with a PivotTable. I'm working in Excel 2010, but 2003 should probably have the same functionality. This is how it would look like.

您可以使用PivotTable完成您的要求。我在 Excel 2010 中工作，但 2003 应该具有相同的功能。这就是它的样子。

The naive VBA approach I was going to do (which I guess you've implemented) was looping through all the items, doing comparisons, and adding them one at a time to the new worksheet. This can be made a bit more efficient if you store the initial range (of 2 columns) in an array, loop through that and store the output in a 2nd array, then copy the array back to a range.

我将要使用的原始 VBA 方法（我猜您已经实现了）是循环遍历所有项目，进行比较，并将它们一次添加到新工作表中。如果将初始范围（2 列）存储在数组中，循环遍历并将输出存储在第二个数组中，然后将数组复制回范围，则可以提高效率。

I'm not sure how much data you have or how long that operation takes. Another alternative would be to use the macro recorder to make a PivotTable and copy the data from there to a new sheet. Here's an example, though you'd want to change the worksheet and range references to make them explicit/dynamic. The example data range is A1:B9.

我不确定您拥有多少数据或该操作需要多长时间。另一种选择是使用宏记录器制作数据透视表并将数据从那里复制到新工作表。这是一个示例，尽管您希望更改工作表和范围引用以使其显式/动态。示例数据范围是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

回答by joiner

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

回答by Motes

your old worksheet is called yourWorksheet. create a new worksheet:

您的旧工作表称为 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

rough and untested, but that's the idea.

粗糙且未经测试，但这就是想法。

回答by er_Hyman

If you use the left command and extract the Item One, Item Two, etc.

如果您使用 left 命令并提取项目一、项目二等。

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

then extract the subItem:

然后提取子项：

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

These will extract the text.

这些将提取文本。

You have to get creative for THREE and FOUR.

你必须为三和四发挥创意。