行列转换问题

汪金鑫

想了很久也不会，只能求助大佬了。

E风卍行H

Sub 转换()
    Const strSplit As String = ","
    Dim rngSave As Range, rngData As Range
    Dim arr, brr(), b As Long, trr1, trr2
    Dim istr1 As String, istr2 As String
    Dim i As Long, j As Long
   
   
    Rem 选择要转换的区域
    On Error Resume Next
    Set rngData = Application.InputBox("请选择要转换的数据区域：", "转换区域", , , , , , 8)
    If rngData Is Nothing Then Exit Sub
   
   
    Rem 判断选择区域
    If rngData.Columns.Count <> 2 Then
        MsgBox "转换区域必须选择两列！"
        Exit Sub
    End If
   
    Rem 结果存放位置
    Set rngSave = Application.InputBox("请选择要存放结果的位置：", "保存位置", , , , , , 8)
    If rngData Is Nothing Then Exit Sub
   
    On Error GoTo 0
   
    On Error GoTo errmsg
   
    arr = rngData.Value
    For i = 1 To UBound(arr)
        istr1 = arr(i, 1)
        istr2 = arr(i, 2)
        Rem 左侧有分隔符
        If InStr(istr1, strSplit) Then
            trr1 = Split(istr1, strSplit)
            Rem 右侧有分隔符
            If InStr(istr2, strSplit) Then
                trr2 = Split(istr2, strSplit)
                Rem 右侧分隔符与左侧相等
                If UBound(trr1) = UBound(trr2) Then
                    For j = 0 To UBound(trr1)
                        b = b + 1
                        ReDim Preserve brr(1 To 2, 1 To b)
                        brr(1, b) = trr1(j)
                        brr(2, b) = trr2(j)
                    Next
                Else
                    Rem 左右分隔符数量不相等则退出程序
                    With rngData.Cells(i, 1)
                        .Select
                        MsgBox .Address & " 单元格分隔数量不相等！"
                    End With
                    
                    Exit Sub
                End If
            Else
                Rem 右侧没有分隔符
                For j = 0 To UBound(trr1)
                    b = b + 1
                    ReDim Preserve brr(1 To 2, 1 To b)
                    brr(1, b) = trr1(j)
                    brr(2, b) = istr2
                Next
            End If
        
        Else
        Rem 左侧没有分隔符
            Rem 右侧有分隔符
            If InStr(istr2, strSplit) Then
                trr2 = Split(istr2, strSplit)
                For j = 0 To UBound(trr2)
                    b = b + 1
                    ReDim Preserve brr(1 To 2, 1 To b)
                    brr(1, b) = istr1
                    brr(2, b) = trr2(j)
                Next
            Else
                Rem 右侧没有分隔符
                b = b + 1
                ReDim Preserve brr(1 To 2, 1 To b)
                brr(1, b) = istr1
                brr(2, b) = istr2
            End If
        End If
    Next
   
    Rem 判断结果区域是否有内容
    Set rngSave = rngSave.Resize(b, 2)
    If Application.WorksheetFunction.CountA(rngSave) <> 0 Then
        MsgBox "结果区域有其他内容！"
        Exit Sub
    End If
   
    Rem 激活工作表（以防选择位置在其他工作表）
    rngSave.Parent.Activate
   
    Rem 输出结果
    rngSave = Application.WorksheetFunction.Transpose(brr)
   
    MsgBox "转换完成！"
   
    Exit Sub

errmsg:
    MsgBox "程序异常退出！"
End Sub

leepoison

测试.rar (69.97 KB, 下载次数: 2)

2023-7-24 23:02 上传

点击文件名下载附件

leepoison

Sub SplitAndArrange()
    Dim ws As Worksheet
    Dim rng As Range
    Dim arrSplit() As String
    Dim i As Long, j As Long, k As Long
    Dim lastRow As Long
   
    '如果你的工作表名字不同，请改为你的工作表名字
    Set ws = ThisWorkbook.Sheets("Sheet1")
   
    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    j = 2 '开始写入的行数
   
    Application.ScreenUpdating = False
   
    For i = 2 To lastRow '从第二行开始处理数据
        If InStr(1, ws.Cells(i, 2).Value, ",") > 0 Then
            arrSplit = Split(ws.Cells(i, 2).Value, ",")
            For k = LBound(arrSplit) To UBound(arrSplit)
                ws.Cells(j, 3).Value = ws.Cells(i, 1).Value
                ws.Cells(j, 4).Value = Trim(arrSplit(k))
                j = j + 1
            Next k
        Else
            ws.Cells(j, 3).Value = ws.Cells(i, 1).Value
            ws.Cells(j, 4).Value = ws.Cells(i, 2).Value
            j = j + 1
        End If
    Next i

    Application.ScreenUpdating = True
End Sub

leepoison

Sub SplitAndArrangeBoth()
    Dim ws As Worksheet
    Dim arrSplitA() As String
    Dim arrSplitB() As String
    Dim i As Long, j As Long, k As Long
    Dim lastRow As Long
   
    '如果你的工作表名字不同，请改为你的工作表名字
    Set ws = ThisWorkbook.Sheets("Sheet1")
   
    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    j = 2 '开始写入的行数
   
    Application.ScreenUpdating = False
   
    For i = 2 To lastRow '从第二行开始处理数据
        arrSplitA = Split(ws.Cells(i, 1).Value, ",")
        arrSplitB = Split(ws.Cells(i, 2).Value, ",")
        
        ' 情况1: A列只有一个值，B列有多个由逗号分隔的值
        If UBound(arrSplitA) = 0 And UBound(arrSplitB) > 0 Then
            For k = LBound(arrSplitB) To UBound(arrSplitB)
                ws.Cells(j, 3).Value = ws.Cells(i, 1).Value
                ws.Cells(j, 4).Value = Trim(arrSplitB(k))
                j = j + 1
            Next k
        ' 情况2: A列和B列都有由逗号分隔的多个值，数量相等
        ElseIf UBound(arrSplitA) = UBound(arrSplitB) Then
            For k = LBound(arrSplitA) To UBound(arrSplitA)
                ws.Cells(j, 3).Value = Trim(arrSplitA(k))
                ws.Cells(j, 4).Value = Trim(arrSplitB(k))
                j = j + 1
            Next k
        Else
            ws.Cells(j, 3).Value = ws.Cells(i, 1).Value
            ws.Cells(j, 4).Value = ws.Cells(i, 2).Value
            j = j + 1
        End If
    Next i

    Application.ScreenUpdating = True
End Sub

xlllw203

PQ 分列+逆透视很简单的，点点鼠标就行了。我贴不了图和附件，只能传个代码看看
let
    源 = Excel.CurrentWorkbook(){[Name="表3"]}[Content],
    更改的类型 = Table.TransformColumnTypes(源,{{"工号", type text}, {"姓名", type text}}),
    按分隔符拆分列 = Table.SplitColumn(更改的类型, "姓名", Splitter.SplitTextByDelimiter(",", QuoteStyle.Csv), {"姓名.1", "姓名.2", "姓名.3"}),
    更改的类型1 = Table.TransformColumnTypes(按分隔符拆分列,{{"姓名.1", type text}, {"姓名.2", type text}, {"姓名.3", type text}}),
    逆透视的列 = Table.UnpivotOtherColumns(更改的类型1, {"工号"}, "属性", "值"),
    按分隔符拆分列1 = Table.SplitColumn(逆透视的列, "工号", Splitter.SplitTextByDelimiter(",", QuoteStyle.Csv), {"工号.1", "工号.2"}),
    更改的类型2 = Table.TransformColumnTypes(按分隔符拆分列1,{{"工号.1", type text}, {"工号.2", type text}}),
    逆透视的其他列 = Table.UnpivotOtherColumns(更改的类型2, {"值"}, "属性.1", "值.1"),
    删除的副本 = Table.Distinct(逆透视的其他列, {"值"}),
    重排序的列 = Table.ReorderColumns(删除的副本,{"值.1", "值", "属性.1"}),
    替换的值 = Table.ReplaceValue(重排序的列,"姓名.1",null,Replacer.ReplaceValue,{"值.1"}),
    删除的列 = Table.RemoveColumns(替换的值,{"属性.1"})
in
    删除的列

一杯绿茶来了

=REDUCE({"工号","姓名"},A14:A18,LAMBDA(x,y,VSTACK(x,IFNA(HSTACK(IFERROR(TEXTSPLIT(y,,","),""),TEXTSPLIT(OFFSET(y,,1),,",")),y))))
365公式

cyh3230

如果不是 365版本的话
M语句可能方便一些

let
    源 = Excel.CurrentWorkbook(){[Name="表1"]}[Content],
    更改的类型 = Table.TransformColumnTypes(源,{{"工号", type text}, {"姓名", type text}}),
    自定义1 = Table.TransformColumns(更改的类型,{"姓名",each Text.Split(_,",")}),
    #"展开的“姓名”" = Table.ExpandListColumn(自定义1, "姓名"),
    自定义2 = Table.TransformColumns(#"展开的“姓名”",{"工号",each try Text.Split(_,",") otherwise {""}}),
    #"展开的“工号”" = Table.ExpandListColumn(自定义2, "工号")
in
    #"展开的“工号”"