用透视表发现门店只能以值的形式显示

鼠标拖动到左边

方法一、用 transpose 函数。
方法二、选择，复制，粘贴选项：转置。

上个附件到百度网盘 。

链接: 网盘链接 提取码: kpf7 复制这段内容后打开百度网盘手机App，操作更方便哦

Option Explicit
Sub abc()
　Dim a, i, j, n, d(1)
　a = Sheets("sheet1").[a1].CurrentRegion.Value
　ReDim b(UBound(a, 2), 10 ^ 3) '最多支持100个种类，如果爆掉自己修改
　For i = 0 To UBound(d)
　　Set d(i) = CreateObject("scripting.dictionary")
　Next
　For j = 3 To UBound(a, 2)
　　d(0)(a(1, j)) = j - 2
　　b(j - 2, 0) = a(1, j)
　Next
　n = 1: b(0, 1) = a(1, 2)
　For i = 2 To UBound(a)
　　If Not d(1).exists(a(i, 1)) Then
　　　n = n + 1: d(1)(a(i, 1)) = n: b(0, n) = a(i, 1)
　　Else
　　　Exit For
　　End If
　　For j = 3 To UBound(a, 2)
　　　If IsNumeric(a(i, j)) Then
　　　　b(d(0)(a(1, j)), d(1)(a(i, 1))) = a(i, j)
' b(d(0)(a(1, j)), d(1)(a(i, 1))) = b(d(0)(a(1, j)), d(1)(a(i, 1))) + a(i, j) + a(i, 2)
' b(d(0)(a(1, j)), 1) = b(d(0)(a(1, j)), 1) + a(i, 2)
　　　End If
　　Next
　Next
　With Sheets("sheet2")
　　.Cells.ClearContents
　　.[a1].Resize(UBound(b) + 1, n + 1) = b
　End With
End Sub

Option Explicit
Sub abc()
　Dim a, i, j, m, n
　a = Sheets("sheet1").[a1].CurrentRegion.Value
　ReDim b(1 To UBound(a, 2) + 1, 1 To UBound(a, 1) + 1)
　For i = 1 To UBound(a)
　　If i > 1 Then n = 1 Else n = 0
　　For j = 1 To UBound(a, 2)
　　　If j > 2 Then m = -1 Else m = 0
　　　b(j + m, i + n) = a(i, j)
　　Next
　Next
　b(1, 2) = a(1, 2)
　With Sheets("sheet2")
　　.Cells.ClearContents
　　.[a1].Resize(UBound(b), UBound(b, 2)) = b
　End With
End Sub

预期想要达到的效果图

Option Explicit
Sub abc()
　Dim a, i, j, k, m, n, p
　With Sheets("sheet1")
　　a = .Range("a1:j" & .[a1].End(xlDown).Row + 1).Value
　End With
　ReDim b(1 To (UBound(a, 2) + 1) * 100, 1 To UBound(a, 1) + 1)
　p = 1
　For i = 2 To UBound(a) - 1
　　If a(i, 2) <> a(i + 1, 2) Then
　　　m = m + 1
　　　For j = p + 1 To i
　　　　If j > 1 Then n = 1 Else n = 0
　　　　For k = 3 To UBound(a, 2)
　　　　　b((m - 1) * (UBound(a, 2) - 2) + k - 1, j - p + n + 1) = a(j, k)
　　　　　b((m - 1) * (UBound(a, 2) - 2) + k - 1, 2) = a(i, 2)
　　　　　b((m - 1) * (UBound(a, 2) - 2) + k - 1, 1) = a(1, k)
　　　　Next
　　　Next
　　　If p = 1 Then
　　　　b(1, 2) = a(1, 2)
　　　　For j = 2 To UBound(a) - 1
　　　　　b(1, j + 1) = a(j, 1)
　　　　　If a(j, 2) <> a(j + 1, 2) Then Exit For
　　　　Next
　　　End If
　　　p = i
　　End If
　Next
　With Sheets("sheet2")
　　.Cells.ClearContents
　　.[a1].Resize(UBound(b), UBound(b, 2)) = b
　End With
End Sub