请大神帮助 万分感谢

lisga1103

附件是一个调研问卷的汇总表，列是调研问卷的问题，其中A-G列是单选，H-Q列是多选；行是每个调研问卷的结果。目前，H-Q列的多选是放在了一个单元格里，每个答案之间用分号隔开了。 现在希望将H-Q列中多选的答案能够分拆一下，也就是说如果选了2个答案，就增加一行，把两个答案分别放在原行和新增行里。如果选了3个答案，就增加两行，把三个答案分开，谢谢了！ 附件是部分数据，实际数据有上千条，手工做得累死，所以求助各位大神，谢谢了！

zopey

是要从结果还原 答题选项？

lisga1103

zopey 发表于 2018-6-8 11:15
是要从结果还原 答题选项？

可以这么说，就是把多选按行还原

一把小刀闯天下

Option Explicit

Sub test()
  Dim i, j, k, arr, m, n, max, pos
  arr = Range("a2:q" & Cells(Rows.Count, "a").End(xlUp).Row)
  ReDim brr(1 To Rows.Count, 1 To UBound(arr, 2))
  ReDim t(8 To UBound(arr, 2))
  For i = 1 To UBound(arr, 1)
    n = n + 1: max = 0: pos = n
    For j = 1 To 7: brr(n, j) = arr(i, j): Next
    For j = 8 To UBound(arr, 2)
      t(j) = Split(arr(i, j), ";")
      If max < UBound(t(j)) Then max = UBound(t(j))
    Next
    n = n + max - 1
    For j = 8 To UBound(arr, 2)
      m = 0
      For k = 0 To UBound(t(j)): brr(pos + m, j) = t(j)(k): m = m + 1: Next
  Next j, i
  With [s2]
    .Resize(Rows.Count - 1, UBound(brr, 2)).ClearContents
    .Resize(n, UBound(brr, 2)) = brr
  End With
End Sub

一把小刀闯天下

'修改了一下，这样更简单一些

Option Explicit

Sub test()
  Dim i, j, k, arr, m, n, pos
  arr = Range("a2:q" & Cells(Rows.Count, "a").End(xlUp).Row)
  ReDim brr(1 To Rows.Count, 1 To UBound(arr, 2))
  ReDim t(8 To UBound(arr, 2))
  For i = 1 To UBound(arr, 1)
    n = n + 1: pos = n
    For j = 1 To 7: brr(n, j) = arr(i, j): Next
    For j = 8 To UBound(arr, 2)
      m = 0: t(j) = Split(arr(i, j), ";")
      For k = 0 To UBound(t(j)): brr(pos + m, j) = t(j)(k): m = m + 1: Next
      If n < pos + m - 2 Then n = pos + m - 2
  Next j, i
  With [s2]
    .Resize(Rows.Count - 1, UBound(brr, 2)).ClearContents
    .Resize(n, UBound(brr, 2)) = brr
  End With
End Sub

lisga1103

一把小刀闯天下 发表于 2018-6-8 12:17
'修改了一下，这样更简单一些

Option Explicit

太牛了，非常非常感谢！