菱形图表

'矩阵列数可以不限
Option Explicit
Sub abc()
　Dim a, i, j, m, n, x, y
　a = [a1].CurrentRegion.Value
　If UBound(a) <> UBound(a, 2) Then MsgBox "!": Exit Sub
　ReDim b(1 To 2 * UBound(a) - 1, 1 To 2 * UBound(a) - 1)
　x = UBound(b) \ 2 + 1: y = 1
　For j = 1 To UBound(a, 2)
　　m = x: n = y
　　For i = 1 To UBound(a)
　　　b(m, n) = a(i, j)
　　　m = m - 1: n = n + 1
　　Next
　　x = x + 1: y = y + 1
　Next
　[a1].Offset(, UBound(a, 2) + 1).Resize(UBound(b), UBound(b, 2)) = b
End Sub

后面修改的被吃掉了，就是2个菱形叠放在一起。

'叠加。另一数据块在[a6:c8]，自己填3*3的数据块就行
Option Explicit
Sub abc()
　Dim a
　a = [a1].CurrentRegion.Value
　ReDim b(1 To 2 * UBound(a) - 1, 1 To 2 * UBound(a) - 1)
　Call fc(a, b, UBound(b) \ 2 + 1, 1)
　a = [a6].CurrentRegion.Value
　Call fc(a, b, UBound(b) \ 2 + 1, 2)
　[f1].Resize(UBound(b), UBound(b, 2)) = b
End Sub
Function fc(a, b, x, y)
　Dim i, j, m, n
　For j = 1 To UBound(a, 2)
　　m = x: n = y
　　For i = 1 To UBound(a)
　　　b(m, n) = a(i, j)
　　　m = m - 1: n = n + 1
　　Next
　　x = x + 1: y = y + 1
　Next
End Function