1

我从导入到 Excel 的程序中获得以下格式的输出：

Item 1  
1       10
2       10
3       20
5       20
8       30
13      30
Item 2  
1       40
2       40
3       50
5       50
8       60
13      60
Item 3  
1       50
2       50
3       40
5       40
8       30
13      30

现在，我想创建一个表，其中每个项目的值彼此相邻放置，如下所示：

        Item 1      Item 2      Item 3
1       10          40          50
2       10          40          50
3       20          50          40
5       20          50          40
8       30          60          30
13      30          60          30

我可以想办法使用公式和INDIRECT其他函数的组合来做到这一点，但我可以马上看到这将是一个巨大的痛苦。有没有聪明的方法来做到这一点？

我的方法是这样的：

=VLOOKUP($A6;indirect("A"&(6+G$5*$X$4):"D"&(30+G$5*$X$4));4;FALSE)

我的第一个查找表来自哪里A6:D30，第二个来自哪里A32:D56。X4包含的值26是每个项目的行数，并且G5:AA5是0, 1, 2 ...。我会将它放在Item 1列表旁边并将其横向和向下拖动。我认为该程序应该可以工作，但出现语法错误。

我没有太多编写 VBA 的经验，但我能够阅读和理解它。

更新：

应悉达多的要求：

在此处输入图像描述

4

3 回答 3

2

你能看看这个。
它采用固定格式，如您的示例中所示。
它可以是动态的，但是您需要自定义代码。

Option Explicit

Sub test()

Dim oCollection         As Collection
Dim oDict               As Variant
Dim oItem               As Object

Dim iCnt                As Integer
Dim iCnt_B              As Integer
Dim iCnt_items          As Integer
Dim iCnt_records        As Integer

Dim iID                 As Integer
Dim iValue              As Integer

Dim strKey              As Variant

'Nr of items
iCnt_items = 3
'Records per item
iCnt_records = 6

'This dictionary will store the items
Set oCollection = New Collection

'Store dictionaries in collection
For iCnt = 0 To iCnt_items - 1
    Set oDict = CreateObject("Scripting.Dictionary")
        For iCnt_B = 1 To iCnt_records
            iID = ThisWorkbook.Sheets(1).Cells((iCnt * (iCnt_records) + (iCnt + 1) + iCnt_B), 1).Value
            Debug.Print iID
            iValue = ThisWorkbook.Sheets(1).Cells((iCnt * (iCnt_records) + (iCnt + 1) + iCnt_B), 2).Value
            Debug.Print iValue
            oDict.Add iID, iValue
        Next iCnt_B
        oCollection.Add oDict, "item " & iCnt
Next iCnt

'Write collection to sheet
iCnt = 0
For Each oItem In oCollection
    iCnt = iCnt + 1
    ThisWorkbook.Sheets(2).Cells(1, 1 + iCnt).Value = "item " & iCnt

    iCnt_B = 0
    For Each strKey In oItem.keys
        iCnt_B = iCnt_B + 1
        ThisWorkbook.Sheets(2).Cells(1 + iCnt_B, 1).Value = strKey
        ThisWorkbook.Sheets(2).Cells(1 + iCnt_B, 1 + iCnt).Value = oItem(strKey)

    Next
Next oItem

End Sub

编辑：抱歉打断了对话->我在编程时没有跟进评论部分。

边注：

如果您使用的范围是动态的，我会使用字典。
我之所以这么说是因为字典对象在其记录上使用了索引。
键对结构为：ID, value
允许您直接访问与给定 ID 对应的值。
在您的示例中，您正在使用清晰的 ID - 值结构。
使用数字 id 实际上是最快的。

于 2013-10-21T12:58:59.027 回答
2

因为我已经在这方面工作了......这是另一种方式..

假设：

  1. 数据从 Sheet1 的第 5 行开始
  2. 输出将在 Sheet2 中生成

代码：

下面的代码使用CollectionsandFormulas来实现你想要的。

Sub Sample()
    Dim wsInput As Worksheet, wsOutput As Worksheet
    Dim ColItems As New Collection, ColSubItems As New Collection
    Dim lRow As Long, i As Long, N As Long
    Dim itm

    Set wsInput = ThisWorkbook.Sheets("Sheet1")
    Set wsOutput = ThisWorkbook.Sheets("Sheet2")

    With wsInput

        lRow = .Range("B" & .Rows.Count).End(xlUp).Row

        .Columns(1).Insert
        .Range("A5:A" & lRow).Formula = "=IF(ISERROR(SEARCH(""Item"",B5,1)),A4,B5)"

        For i = 5 To lRow
            On Error Resume Next
            If InStr(1, .Range("B" & i).Value, "item", vbTextCompare) Then
                ColItems.Add .Range("B" & i).Value, CStr(.Range("B" & i).Value)
            Else
                ColSubItems.Add .Range("B" & i).Value, CStr(.Range("B" & i).Value)
            End If
            On Error GoTo 0
        Next i
    End With

    With wsOutput
        .Cells.ClearContents
        N = 2

        '~~> Create Header in Row 1
        For Each itm In ColItems
            .Cells(1, N).Value = itm
            N = N + 1
        Next

        N = 2

        '~~> Create headers in Col 1
        For Each itm In ColSubItems
            .Cells(N, 1).Value = itm
            N = N + 1
        Next

        lRow = .Range("A" & .Rows.Count).End(xlUp).Row
        lcol = .Cells(1, .Columns.Count).End(xlToLeft).Column

        j = 2

        For i = 2 To lcol
            .Range(.Cells(j, i), .Cells(lRow, i)).Formula = "=SUMIFS(" & _
                                                            wsInput.Name & _
                                                            "!C:C," & wsInput.Name & _
                                                            "!A:A," & .Name & _
                                                            "!$" & _
                                                            Split(.Cells(, i).Address, "$")(1) & _
                                                            "$1," & _
                                                            wsInput.Name & _
                                                            "!B:B," & _
                                                            .Name & _
                                                            "!A:A)"
        Next i

        .Rows("1:" & lRow).Value = .Rows("1:" & lRow).Value
    End With

    wsInput.Columns(1).Delete
End Sub

截屏：

在此处输入图像描述

于 2013-10-21T13:47:34.650 回答
0

这是我尝试过的。

表 1 包含数据。结果在表 2 中生成

子 createTable()

Dim counter As Integer
Dim countRow As Integer
Dim flag As Boolean
Dim cellAddress As String
flag = True
countRow = 2
counter = 2

ThisWorkbook.Sheets("Sheet1").Activate

For Each cell In Range("a:a")
If counter = 2 Then
    If InStr(1, cell.Value, "Item") Then
        ThisWorkbook.Sheets("Sheet2").Activate
        ActiveSheet.Cells(1, counter).Value = cell.Value
        firstItem = cell.Value
        counter = counter + 1

     End If
Else
         ThisWorkbook.Sheets("Sheet2").Activate
          If InStr(1, cell.Value, "Item") Then
        ThisWorkbook.Sheets("Sheet2").Activate
        ActiveSheet.Cells(1, counter).Value = cell.Value
        counter = counter + 1
        flag = False
         End If
         If flag = True Then
         Cells(cell.Row, cell.Column) = cell.Value
         End If

End If
If cell.Value = vbNullString Then
Exit For
End If
Next cell

ThisWorkbook.Sheets("Sheet1").Activate

Application.CutCopyMode = False

Dim counteradd As Integer
counteradd = 2
For Each cell In Range("a:a")
    v = cell.Value
    If InStr(1, cell.Value, "Item") Then
        If cell.Offset(1, 1).Select <> vbNullString Then
            Range(Selection, Selection.End(xlDown)).Select
            Selection.Copy
            Sheets("Sheet2").Select
            Cells(2, counteradd).Select
            ActiveSheet.Paste
            Application.CutCopyMode = False
            counteradd = counteradd + 1
            ThisWorkbook.Sheets("Sheet1").Activate
        End If
    End If
Next cell

结束子

于 2013-10-21T14:36:28.480 回答