尺码竖转换横，哥哥姐姐们帮我写下VBA代码，谢谢啦。

313667354

尺码竖转换横，哥哥姐姐们帮我写下VBA代码，谢谢啦

3190496160

Sub 转换()
Application.ScreenUpdating = False
Dim ar As Variant
Dim d As Object
Set d = CreateObject("scripting.dictionary")
ReDim arr(1 To Sheets.Count)
With Sheets("原数据")
    r = .Cells(Rows.Count, 1).End(xlUp).Row
    If r < 2 Then MsgBox "数据源为空！": End
    ar = .Range("a1:g" & r)
End With
With Sheets("结果")
    .[a1].CurrentRegion.Offset(1) = Empty
    br = .Range("a1:o" & r)
    For j = 6 To UBound(br, 2)
        d(Trim(br(1, j))) = j
    Next j
    k = 1
    For i = 2 To UBound(ar)
        If Trim(ar(i, 1)) <> "" Then
            zd = ar(i, 1) & "|" & ar(i, 2) & "|" & ar(i, 3) & "|" & ar(i, 4) & "|" & ar(i, 5)
            t = d(zd)
            If t = "" Then
                k = k + 1
                d(zd) = k
                t = k
                For j = 1 To 5
                    br(k, j) = ar(i, j)
                Next j
            End If
            lh = d(ar(i, 6))
            If lh <> "" Then
                br(t, lh) = br(t, lh) + ar(i, 7)
            End If
        End If
    Next i
   .[a1].Resize(k, UBound(br, 2)) = br
End With
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub

3190496160

3190496160

竖转横.rar (21.87 KB, 下载次数: 5)

2023-9-7 11:24 上传

点击文件名下载附件

313667354

3190496160 发表于 2023-9-7 11:24

谢谢，非常感谢。