excel - 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 方法（我猜你已经实现了）是循环遍历所有项目，进行比较，然后一次将它们添加到新工作表中。如果将初始范围（2 列）存储在一个数组中，循环遍历该范围并将输出存储在第二个数组中，然后将数组复制回一个范围，则可以提高效率。

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

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

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

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

然后提取子项：

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

这些将提取文本。

你必须对三四有创意。

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

excel - VBA宏将所有行分组在一个标题下，当存在多个标题时为标题

4 回答 4

Related

Reference