Question

我目前有这张表：

我想按最后一栏对其进行分类，因此它显示为：

我认为这对于数据透视表或某些东西可能是可行的，但似乎没有。我也尝试过使用切片器但是没有达到预期的效果（只是隐藏和取消隐藏行）。这似乎是一个普通而简单的想要做的事情，但我似乎无法弄明白。

编辑：我真的不想在图像中重新创建表格，因为该表格不能正确排序或搜索（因为描述该类别的“标题”行将被不正确地排序并出现在搜索中），我只是想要它与图像的显示方式类似。

表格数据：

| Armor           | Cost    | AC | Strength Requirement | Stealth      | Weight | Class        |
|-----------------|---------|----|----------------------|--------------|--------|--------------|
| Padded          | 5 gp    | 11 | —                    | Disadvantage | 8 lb   | Light Armor  |
| Leather         | 10 gp   | 11 | —                    | —            | 10 lb  | Light Armor  |
| Studded leather | 45 gp   | 12 | —                    | —            | 13 lb  | Light Armor  |
| Hide            | 10 gp   | 12 | —                    | —            | 12 lb  | Medium Armor |
| Chain shirt     | 50 gp   | 13 | —                    | —            | 20 lb  | Medium Armor |
| Scale mail      | 50 gp   | 14 | —                    | Disadvantage | 45 lb  | Medium Armor |
| Breastplate     | 400 gp  | 14 | —                    | —            | 20 lb  | Medium Armor |
| Half plate      | 750 gp  | 15 | —                    | Disadvantage | 40 lb  | Medium Armor |
| Ring mail       | 30 gp   | 14 | —                    | Disadvantage | 40 lb  | Heavy Armor  |
| Chain mail      | 75 gp   | 16 | 13                   | Disadvantage | 55 lb  | Heavy Armor  |
| Splint          | 200 gp  | 17 | 15                   | Disadvantage | 60 lb  | Heavy Armor  |
| Plate           | 1500 gp | 18 | 15                   | Disadvantage | 65 lb  | Heavy Armor  |
| Shield          | 10 gp   | +2 | —                    | —            | 6 lb   | Shield       |

Answer 1

您可以按如下方式创建自己的查找：

Option Explicit
Public outputRow   As Long
'VBE > Tools > references > tick MS HTML Object Library, MS XML

Public Sub Main()
    outputRow = 0
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Worksheets("Output")   ''change as appropriate
    ws.Cells.ClearContents
    GetTables ws
    AddKeys ws, 1
    ws.Cells.Columns.AutoFit
    ws.Columns("A:G").NumberFormat = "@"
End Sub

Public Sub GetTables(ByVal ws As Worksheet)
    Dim http As New XMLHTTP60, html As New HTMLDocument, arr() As Variant 'XMLHTTP60     This will vary according to your Excel version

    arr = Array("Currency", "Armor", "Selling Treasure", "Armor", "Weapons", _
                "Adventuring Gear", "Tools", "Mounts and Vehicles", "Trade Goods", "Expenses")

    Dim i As Long
    For i = LBound(arr) To UBound(arr)
        DoEvents
        With http
            .Open "GET", ConstructURL(LCase$(arr(i))), False
            .send
            html.body.innerHTML = .responseText
        End With

        PrintTables html, ws
    Next i
End Sub

Public Sub PrintTables(ByVal html As HTMLDocument, ByVal ws As Worksheet)

    Dim rng As Range, tbl As HTMLTable, currentRow As Object, currentColumn As Object, i As Long, counter As Long

    For Each tbl In html.getElementsByTagName("Table")
        counter = counter + 1
        outputRow = outputRow + 1
        Set rng = ws.Range("B" & outputRow)
        rng.Offset(, -1) = "Table " & counter

        For Each currentRow In tbl.Rows
            For Each currentColumn In currentRow.Cells
                rng.Value = currentColumn.outerText
                Set rng = rng.Offset(, 1)
                i = i + 1
            Next currentColumn
            outputRow = outputRow + 1
            Set rng = rng.Offset(1, -i)
            i = 0
        Next currentRow
    Next tbl
End Sub

Public Function ConstructURL(ByVal item As String) As String
    ConstructURL = "https://dnd5e.info/equipment/" & item
End Function

Public Sub AddKeys(ByVal ws As Worksheet, Optional ByVal targetColumn As Long = 1)
    Dim loopColumn As Range, rng As Range
    Set loopColumn = ws.UsedRange.Columns(targetColumn)
    Dim cat As String

    For Each rng In loopColumn.Cells
        If InStr(1, rng.Text, "Table") > 0 Then
            cat = rng.Offset(, 1)
        End If
        If Not IsEmpty(rng.Offset(, 1)) And Not IsEmpty(rng.Offset(, 2)) Then
            If IsEmpty(rng) And Not IsEmpty(rng.Offset(, 2)) Then
                rng = cat & rng.Offset(, 1)
            End If
            If IsEmpty(rng) And IsEmpty(rng.Offset(, 2)) Then
                rng = cat & rng.Offset(, 1)
            End If
        End If
    Next rng
End Sub

<强>输出：

注意列A具有可用于查找项目的唯一键。但是，您需要知道您感兴趣的列，尽管您可以在列标题上匹配。你可以整理一下，但已经适合给定项目的唯一查找。

Excel - 按列对表进行分类

1 个答案: