Question

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

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

        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的经验，但我有能力阅读和理解它。

更新

在Siddharth的要求下：

enter image description here

Answer 1

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

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

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

旁注：

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

Answer 2

因为我已经在研究过......这是另一种方式..

<强>假设：

数据从Sheet1
将在Sheet2中生成输出

<强>代码：

以下代码使用Collections和Formulas来实现您的目标。

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

<强>截图：

enter image description here

Answer 3

这就是我的尝试。

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

Sub 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

End Sub

从Excel中的导入列表创建表

3 个答案: