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

Answer 1

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

Source Data

PivotTable

我要做的天真的VBA方法（我猜你已经实现了）循环遍历所有项目，进行比较，并一次一个地添加到新工作表中。如果将初始范围（2列）存储在数组中，循环并将输出存储在第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

Answer 2

您的旧工作表称为您的工作表。创建一个新的工作表：

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

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

Answer 3

如果您使用左命令并提取第一项，第二项等

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

然后提取subItem：

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

这些将提取文本。

你必须有三分和四分的创意。

Answer 4

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

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

4 个答案: