缩小Excel数据与重叠索引/重复单词出现

Question

我有一张excel表格，其格式如下：

我想将其格式化为：

这是大约40,000个信息单元格，所以有什么办法可以手动完成吗？

Answer 1

您可以使用= SUMIF来实现此目的，因为您似乎将数字作为值。 创建新工作表，将数据表中的A列复制到新工作表中，然后删除重复项。将第1行从数据表复制到新工作表。 在表2单元格B2中使用此公式：

=SUMIF(Sheet1!$A:$A;Sheet2!$A2;Sheet1!B:B)

将公式向右拖动，然后向下拖动。

Answer 2

我绝不是一位优秀的专家，这将是我的第一个回答。请考虑到这一点。

我已经检查过它并且有效。 我在Sheet1中添加了一个命令按钮（原始数据所在的位置），当单击时，此代码将格式化数据写入Sheet2。

无需手动删除重复项！

Dim dU1 As Object, cU1 As Variant, iU1 As Long, lrU As Long
Dim MyArray() As Variant
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim h As Integer

Private Sub CommandButton1_Click()

'Get unique indexes
Set dU1 = CreateObject("Scripting.Dictionary")
lrU = Cells(Rows.Count, 1).End(xlUp).Row 'number of rows
cU1 = Range("A2:A" & lrU) 'Assuming your data starts in A2
For iU1 = 1 To UBound(cU1, 1)
   dU1(cU1(iU1, 1)) = 1
Next iU1

'Now dU1 contains indexes as unique values (about, absence, etc.)

For i = 0 To dU1.Count - 1 'for each index
    ReDim MyArray(1 To 1) As Variant 'starts a "new" array

    For j = 2 To 9 'each of the columns with values (D1-D8)
        a = 0
        For k = 2 To lrU 'all rows
            If (Worksheets("Sheet1").Cells(k, 1).Value = dU1.keys()(i) And Worksheets("Sheet1").Cells(k, j).Value <> "") Then
                    MyArray(UBound(MyArray)) = Worksheets("Sheet1").Cells(k, j).Value 'add value to array
                    ReDim Preserve MyArray(1 To UBound(MyArray) + 1) As Variant 'resize array (now is 1 element longer)
                    a = a + 1
            End If
        Next
        If a = 0 Then 'if no value found, add an element to array anyway
                    MyArray(UBound(MyArray)) = "" 'add value to array
                    ReDim Preserve MyArray(1 To UBound(MyArray) + 1) As Variant 'resize array (now is 1 element longer)
        End If
    Next
    Worksheets("Sheet2").Cells(i + 2, 1) = dU1.keys()(i) 'write indexes in another sheet

    For h = 2 To UBound(MyArray)
            Worksheets("Sheet2").Cells(i + 2, h) = MyArray(h - 1)
    Next
Next
End Sub