|
|
Sub 逆透视列()
Dim arr, brr(), n%
Set yssjq = Application.InputBox("请点选:原始数据区域中的任意单元格（包含行标题和列标题）", Type:=8)
arr = yssjq.CurrentRegion
qsl = Val(InputBox("请输入:从第几列开始将列字段转向行方向（以区域为参照物）：", "要开始列传行的起始数字列号", "2"))
bths = Val(InputBox("请输入:列字段表头共有多少行：", "复合表头行数", "1"))
bb = MsgBox("选择： 是 为忽略空值否 为允许空值存在", vbYesNo)
Set jgdyg = Application.InputBox("请点选:存放结果的 起始单元格", Type:=8)
jgdyg.CurrentRegion.Clear
For i = qsl To UBound(arr, 2)
For j = bths + 1 To UBound(arr)
If bb = 6 Then
If arr(j, i) <> "" Then
n = n + 1
ReDim Preserve brr(1 To qsl + bths, 1 To n + 1)
For k = 1 To qsl - 1
If Len(arr(k, i)) >= 12 Then arr(j, k) = "'" & arr(j, k)
If Len(arr(j, k)) = 0 Then arr(j, k) = brr(k, n)
brr(k, n + 1) = arr(j, k)
Next k
For k = 1 To bths
If Len(arr(k, i)) = 0 Then arr(k, i) = brr(qsl + k - 1, n)
If Len(arr(k, i)) >= 12 Then arr(j, k) = "'" & arr(j, k)
brr(qsl + k - 1, n + 1) = arr(k, i) '循环要转到行的列字段表头
Next k
If Len(arr(k, i)) >= 12 Then arr(j, k) = "'" & arr(j, k)
brr(qsl + bths, n + 1) = arr(j, i)
End If
Else
n = n + 1
ReDim Preserve brr(1 To qsl + bths, 1 To n + 1)
For k = 1 To qsl - 1
If Len(arr(k, i)) >= 12 Then arr(j, k) = "'" & arr(j, k)
If Len(arr(j, k)) = 0 Then arr(j, k) = brr(k, n)
brr(k, n + 1) = arr(j, k)
Next k
For k = 1 To bths
If Len(arr(k, i)) = 0 Then arr(k, i) = brr(qsl + k - 1, n)
If Len(arr(k, i)) >= 12 Then arr(j, k) = "'" & arr(j, k)
brr(qsl + k - 1, n + 1) = arr(k, i) '循环要转到行的列字段表头
Next k
If Len(arr(k, i)) >= 12 Then arr(j, k) = "'" & arr(j, k)
brr(qsl + bths, n + 1) = arr(j, i)
End If
Next
Next
For k = 1 To qsl - 1
brr(k, 1) = arr(1, k) '写入转置字段列之前的标题内容
Next k
jgdyg.Resize(UBound(brr, 2), UBound(brr, 1)) = Application.Transpose(brr)
End Sub |
|
