[求助] 请问怎样将 表1 转换成 表2 的格式

仙子

请问怎样将  sheet1  转换成 sheet2  的格式？感谢！

gufengaoyue

表呢？上传附件~

仙子

感谢！ 新建 Microsoft Excel 工作表.rar (8.77 KB, 下载次数: 11)

2019-1-23 11:36 上传

点击文件名下载附件

gykg-excel

可以使用powerquery的逆透视列功能，选择B:O列，点击逆透视列。

cjc209

Sub 二维转一维()
Dim i%, arr, crr
arr = Application.InputBox("选择区域", Type:=8)
Set tishi = Application.InputBox("选择存放起始单元格", Type:=8)
t1 = UBound(arr)
t2 = UBound(arr, 2)
qsl = Val(InputBox("请输入装置的起始列（以区域为参照物）：", "拆分表格", "1"))
bb = MsgBox("选择： 是 为忽略空值  否 为允许空值存在", vbYesNo)
Application.ScreenUpdating = False
Application.DisplayAlerts = False
ReDim brr(1 To t1 * t2, 1 To 3 + qsl - 1)
If bb = 6 Then
For i = 2 To t1
    m = 1 + qsl
    For k = i To i + t2 - 2
    If arr(i, m) <> "" And arr(i, 1) <> "" Then
        n = n + 1
        brr(n, 1) = arr(i, qsl)
        brr(n, 2) = arr(1, m)
        brr(n, 3) = arr(i, m)
    If qsl > 1 Then
      For ls = 1 To qsl - 1
        If ls <= qsl - 1 Then
         tishi.Offset(n, ls - 1) = arr(i, ls)
        End If
      Next
      ls = 0
     End If
    End If
        m = m + 1
        If m > t2 Then GoTo 1
    Next k
1:
Next i
Else
For i = 2 To t1
    m = 1 + qsl
    For k = i To i + t2 - 2
    If arr(i, 1) <> "" Then
        n = n + 1
       brr(n, 1) = arr(i, qsl)
        brr(n, 2) = arr(1, m)
        brr(n, 3) = arr(i, m)
    If qsl > 1 Then
      For ls = 1 To qsl - 1
        If ls <= qsl - 1 Then
         tishi.Offset(n, ls - 1) = arr(i, ls)
        End If
      Next
      ls = 0
     End If
    End If
      m = m + 1
    If m > t2 Then GoTo 2
    Next k
2:
Next i
End If
For l = 1 To qsl
tishi.Offset(, l - 1) = arr(1, l)
Next
  tishi.Offset(1, qsl - 1).Resize(UBound(brr), 3 + qsl - 1) = brr
  Application.DisplayAlerts = True
Application.ScreenUpdating = True
    MsgBox "转置完毕！"
End Sub

仙子

好的，感谢gykg-excel 老师！

仙子

感谢cjc209 老师的详细解答，问题顺利解决！