一个我不知道怎么形容的难题，所以也搜不到答案。请高手给看看。

peiyun1982 · 发表于 2014-12-25 15:50

本帖子刚刚发在了Excel函数与公式专区。朋友们说我这个问题应该到VB专区来问。于是我来请教一下。对了，本人不懂VB，听人说这个要求需要VB才能实现，所以我正在看置顶的帖子里关于VB的介绍。也请高手给的解答尽量详细一点好让我能操作。谢谢！

我的数据库结构如下表

现在我需要将表中的行拆分成下面的样式

[size=0.83em]2014-12-25 15:02 上传
下载附件 [size=0.83em](74.79 KB)

我希望大家看得懂。是简单的排列组合。
但是我不知道该如何实现。
顺便说一下，原始数据很大。每个表大概2万行。拆分之后大概20-40万行。手工几乎不可能实现。
如果没有好的一步到位的办法，中间经过几次手动干预也行。
这个是实际工作中遇到的难题，求各位给个办法。多谢啦！

说明：D到H的数据是零件的详细信息。
比如第二行中这个零件，在2009到2011年生产的汽车中，1.2/1.4/1.6三个排量，手动挡和自动挡都会用到它。
而第四行这个零件，就只在2007年，1.6排量，自动挡的车型中才会用到。
我现在的工作就是把每个零件的ABC三列变成单独的唯一信息。所以原数据的第二行就需要拆分成新数据的2到19行

附件在这里

测试.rar (9.11 KB, 下载次数: 30)

MicrosoftEH · 发表于 2014-12-25 16:30

关注学习中 ... ...

zm0115 · 发表于 2014-12-25 16:31

请测试

Sub Test()
Dim infoarr, arr1, arr2, arr3
Dim r, a1, a2, a3, c
Dim Rrow As Long
Dim resultarr()
Dim k As Long
Sheet2.Cells(2, 1).Resize(Rows.Count - 1, 8).ClearContents
infoarr = Sheet1.Range("a2:h" & Sheet1.Cells(Rows.Count, 1).End(3).Row)
k = 1
For r = 1 To UBound(infoarr, 1)
arr1 = Split(WorksheetFunction.Substitute(infoarr(r, 1), "，", ",") & ",", ",")
arr2 = Split(WorksheetFunction.Substitute(infoarr(r, 2), "，", ",") & ",", ",")
arr3 = Split(WorksheetFunction.Substitute(infoarr(r, 3), "，", ",") & ",", ",")
For a1 = 0 To UBound(arr1)
If arr1(a1) <> "" Then
For a2 = 0 To UBound(arr2)
If arr2(a2) <> "" Then
For a3 = 0 To UBound(arr3)
If arr3(a3) <> "" Then
ReDim Preserve resultarr(1 To 8, 1 To k)
resultarr(1, k) = arr1(a1)
resultarr(2, k) = arr2(a2)
resultarr(3, k) = arr3(a3)
For c = 4 To 8
resultarr(c, k) = infoarr(r, c)
Next
k = k + 1
End If
Next
End If
Next
End If
Next
Next
Sheet2.Cells(2, 1).Resize(UBound(resultarr, 2), 8) = WorksheetFunction.Transpose(resultarr)
MsgBox "OK"
Sheet2.Select
End Sub

复制代码

魂断蓝桥 · 发表于 2014-12-25 16:34

Sub a()
Dim arr, brr(1 To 1048575, 1 To 8), i, m As Long, tmp1, tmp2, tmp3, j, k, t As Byte
Cells.Replace "，", ","
arr = [a1].CurrentRegion
For i = 2 To UBound(arr)
If Right(arr(i, 1), 1) = "," Then arr(i, 1) = Left(arr(i, 1), Len(arr(i, 1)) - 1)
If Right(arr(i, 2), 1) = "," Then arr(i, 2) = Left(arr(i, 2), Len(arr(i, 2)) - 1)
If Right(arr(i, 3), 1) = "," Then arr(i, 3) = Left(arr(i, 3), Len(arr(i, 3)) - 1)
For j = 0 To UBound(Split(arr(i, 1), ","))
      For k = 0 To UBound(Split(arr(i, 2), ","))
         For t = 0 To UBound(Split(arr(i, 3), ","))
            m = m + 1
            tmp1 = Split(arr(i, 1), ",")
            tmp2 = Split(arr(i, 2), ",")
            tmp3 = Split(arr(i, 3), ",")
            brr(m, 1) = tmp1(j)
            brr(m, 2) = tmp2(k)
            brr(m, 3) = tmp3(t)
            brr(m, 4) = arr(i, 4)
            brr(m, 5) = arr(i, 5)
            brr(m, 6) = arr(i, 6)
            brr(m, 7) = arr(i, 7)
            brr(m, 8) = arr(i, 8)
         Next
      Next
Next
Next
Sheet2.Cells.Clear
Sheet2.[a2].Resize(m, 8) = brr
End Sub

zm0115 · 发表于 2014-12-25 16:35

测试.zip (17.69 KB, 下载次数: 10) 忘了附件

peiyun1982 · 发表于 2014-12-25 21:01

呃……看起来……嗯……好吧我没看懂。我回去好好研究下，谢谢斑竹大人！

peiyun1982 · 发表于 2014-12-25 21:01

魂断蓝桥发表于 2014-12-25 16:34
Sub a()
Dim arr, brr(1 To 1048575, 1 To 8), i, m As Long, tmp1, tmp2, tmp3, j, k, t As Byte
Cells. ...

哦，也谢谢你！我回去仔细看看这些代码是什么意思。非常感谢！有不懂的再来请教

peiyun1982 · 发表于 2014-12-26 00:29

本帖最后由 peiyun1982 于 2014-12-26 00:32 编辑

实在有点难哦，很多公式百度不到

peiyun1982 · 发表于 2014-12-26 00:35

魂断蓝桥发表于 2014-12-25 16:34
Sub a()
Dim arr, brr(1 To 1048575, 1 To 8), i, m As Long, tmp1, tmp2, tmp3, j, k, t As Byte
Cells. ...

你好，首先再次感谢你的回复。我在测试的过程中发现了几个问题，希望您能帮我解答一下。
1.A列或B列如果缺少数据，则整行就不会在结果中显示。
2.C列如果缺少数据，会提示错误，不能继续运行。
而我希望在任何一列缺少数据的情况下，仍然可以用剩余的列进行排列组合显示结果。
如果这3列都没有数据，那么就直接在结果里显示D到H的信息。

3.现在这个表数据不能太多。我经过测试，最多支持到7000多行。再多的话就会报错。请帮忙看下是什么原因呗。

peiyun1982 · 发表于 2014-12-26 00:45

魂断蓝桥发表于 2014-12-25 16:34
Sub a()
Dim arr, brr(1 To 1048575, 1 To 8), i, m As Long, tmp1, tmp2, tmp3, j, k, t As Byte
Cells. ...

哦对了还有个问题。因为每个表的格式不都一样。所以我举一反三了一下。
如果我的表格有20列，我需要用3,4,5列进行排列组合，我就给改成这样了，测试了一下居然能用。
但是VBA的很多命令在百度里搜索不到，所以我也不知道是什么意思。可不可以帮我解答一下呢？我也好知其所以然。不胜感激

		自动登录	找回密码
密码			免费注册

[求助] 一个我不知道怎么形容的难题，所以也搜不到答案。请高手给看看。