[已解决]对单元格的内容进行拆分然后和前两列内容相应对齐

wfykhgmqtdh

要求在表格里面有说明，麻烦高手看一下能不能解决啊 提取单元格的数据并对其.rar (49.6 KB, 下载次数: 19)

2013-1-28 17:51 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

hwc2ycy

2013-1-28 19:02

1. Option Explicit
   
2. 
   
3. Sub 数据整理()
   
4.     Dim arr, iRow&, i&, j As Byte
   
5.     Dim Record&, Temp, Tempstr$
   
6.     Dim arrResult()
   
7.     Dim reg As Object
   
8.     Dim t#
   
9.     t = Timer
   
10.     iRow = Cells(Rows.Count, 1).End(xlUp).Row
    
11.     arr = Range("a1:c" & iRow)
    
12.     Record = 1
    
13.     Application.ScreenUpdating = False
    
14.     ReDim arrResult(1 To 3, 1 To 1)
    
15.     For i = 1 To 3
    
16.         arrResult(i, 1) = arr(1, i)
    
17.     Next
    
18. 
    
19.     Set reg = CreateObject("VBScript.regExp")
    
20.     With reg
    
21.         .Global = True
    
22.         .Pattern = "\,?\d+?\.?"
    
23. 
    
24.         For i = LBound(arr) + 1 To UBound(arr)
    
25.             Tempstr = StrConv(Replace(arr(i, 3), "1.", ""), vbNarrow)
    
26.             Tempstr = Replace(Tempstr, " ", "")
    
27.             Tempstr = Replace(Tempstr, vbLf, "")
    
28.             Tempstr = Replace(Tempstr, ";", ",")
    
29.             Tempstr = Replace(Tempstr, "?", ",")
    
30.             
    
31.             If .test(Tempstr) Then
    
32.                 Temp = Split(.Replace(Tempstr, ","), ",")
    
33.                 For j = LBound(Temp) To UBound(Temp)
    
34.                     Record = Record + 1
    
35.                     ReDim Preserve arrResult(1 To 3, 1 To Record)
    
36.                     arrResult(1, Record) = arr(i, 1)
    
37.                     arrResult(2, Record) = arr(i, 2)
    
38.                     arrResult(3, Record) = Temp(j)
    
39.                 Next
    
40.             Else
    
41.                 If Len(Tempstr) = 0 Then
    
42.                     Record = Record + 1
    
43.                     ReDim Preserve arrResult(1 To 3, 1 To Record)
    
44.                     arrResult(1, Record) = arr(i, 1)
    
45.                     arrResult(2, Record) = arr(i, 2)
    
46.                     arrResult(3, Record) = arr(i, 3)
    
47.                 Else
    
48. 
    
49.                     Temp = Split(Tempstr, ",")
    
50.                     For j = LBound(Temp) To UBound(Temp)
    
51.                         Record = Record + 1
    
52.                         ReDim Preserve arrResult(1 To 3, 1 To Record)
    
53.                         arrResult(1, Record) = arr(i, 1)
    
54.                         arrResult(2, Record) = arr(i, 2)
    
55.                         arrResult(3, Record) = Temp(j)
    
56.                     Next
    
57. 
    
58.                 End If
    
59.             End If
    
60.         Next
    
61.     End With
    
62.     Worksheets.Add
    
63.     Range("a1").Resize(Record, 3) = WorksheetFunction.Transpose(arrResult)
    
64.     With Columns("a:c")
    
65.         .HorizontalAlignment = xlLeft
    
66.         .AutoFit
    
67.     End With
    
68.     Application.ScreenUpdating = True
    
69.     t = Timer - t
    
70.     MsgBox "转化完成, 用时一共 " & t & "秒"
    
71. End Sub

复制代码

能做出这个表的，绝对是人才。

跳转到最佳答案楼层

hwc2ycy

1. Sub 数据整理()
   
2.     Dim arr, iRow&, i&, j As Byte
   
3.     Dim Record&, Temp, Tempstr$
   
4.     Dim arrResult()
   
5.     Dim reg As Object
   
6.     Dim t#
   
7.     t = Timer
   
8.     iRow = Cells(Rows.Count, 1).End(xlUp).Row
   
9.     arr = Range("a1:c" & iRow)
   
10.     Record = 1
    
11.     Application.ScreenUpdating = False
    
12.     ReDim arrResult(1 To 3, 1 To 1)
    
13.     For i = 1 To 3
    
14.         arrResult(i, 1) = arr(1, i)
    
15.     Next
    
16. 
    
17.     Set reg = CreateObject("VBScript.regExp")
    
18.     With reg
    
19.         .Global = True
    
20.         .Pattern = "\,?\d+\."
    
21. 
    
22.         For i = LBound(arr) + 1 To UBound(arr)
    
23.             Tempstr = Replace(arr(i, 3), "1.", "")
    
24.             Tempstr = Replace(Tempstr, " ", "")
    
25.             Tempstr = Replace(Tempstr, vbLf, "")
    
26.             If .test(Tempstr) Then
    
27.                 Temp = Split(.Replace(Tempstr, ","), ",")
    
28.                 For j = LBound(Temp) To UBound(Temp)
    
29.                     Record = Record + 1
    
30.                     ReDim Preserve arrResult(1 To 3, 1 To Record)
    
31.                     arrResult(1, Record) = arr(i, 1)
    
32.                     arrResult(2, Record) = arr(i, 2)
    
33.                     arrResult(3, Record) = Temp(j)
    
34.                 Next
    
35.             Else
    
36.                 If Len(Tempstr) = 0 Then
    
37.                     Record = Record + 1
    
38.                     ReDim Preserve arrResult(1 To 3, 1 To Record)
    
39.                     arrResult(1, Record) = arr(i, 1)
    
40.                     arrResult(2, Record) = arr(i, 2)
    
41.                     arrResult(3, Record) = arr(i, 3)
    
42.                 Else
    
43. 
    
44.                     Temp = Split(Tempstr, ",")
    
45.                     For j = LBound(Temp) To UBound(Temp)
    
46.                         Record = Record + 1
    
47.                         ReDim Preserve arrResult(1 To 3, 1 To Record)
    
48.                         arrResult(1, Record) = arr(i, 1)
    
49.                         arrResult(2, Record) = arr(i, 2)
    
50.                         arrResult(3, Record) = Temp(j)
    
51.                     Next
    
52. 
    
53.                 End If
    
54.             End If
    
55.         Next
    
56.     End With
    
57.     Worksheets.Add
    
58.     Range("a1").Resize(Record, 3) = WorksheetFunction.Transpose(arrResult)
    
59.     With Columns("a:c")
    
60.         .HorizontalAlignment = xlLeft
    
61.         .AutoFit
    
62.     End With
    
63.     Application.ScreenUpdating = True
    
64.     t = Timer - t
    
65.     MsgBox "转化完成, 用时一共 " & t & "秒"
    
66. End Sub

复制代码

hwc2ycy

1. Option Explicit
   
2. 
   
3. Sub 数据整理()
   
4.     Dim arr, iRow&, i&, j As Byte
   
5.     Dim Record&, Temp, Tempstr$
   
6.     Dim arrResult()
   
7.     Dim reg As Object
   
8.     Dim t#
   
9.     t = Timer
   
10.     iRow = Cells(Rows.Count, 1).End(xlUp).Row
    
11.     arr = Range("a1:c" & iRow)
    
12.     Record = 1
    
13.     Application.ScreenUpdating = False
    
14.     ReDim arrResult(1 To 3, 1 To 1)
    
15.     For i = 1 To 3
    
16.         arrResult(i, 1) = arr(1, i)
    
17.     Next
    
18. 
    
19.     Set reg = CreateObject("VBScript.regExp")
    
20.     With reg
    
21.         .Global = True
    
22.         .Pattern = "\,?\d+?\.?"
    
23. 
    
24.         For i = LBound(arr) + 1 To UBound(arr)
    
25.             Tempstr = StrConv(Replace(arr(i, 3), "1.", ""), vbNarrow)
    
26.             Tempstr = Replace(Tempstr, " ", "")
    
27.             Tempstr = Replace(Tempstr, vbLf, "")
    
28.             Tempstr = Replace(Tempstr, ";", ",")
    
29.             Tempstr = Replace(Tempstr, "?", ",")
    
30.             
    
31.             If .test(Tempstr) Then
    
32.                 Temp = Split(.Replace(Tempstr, ","), ",")
    
33.                 For j = LBound(Temp) To UBound(Temp)
    
34.                     Record = Record + 1
    
35.                     ReDim Preserve arrResult(1 To 3, 1 To Record)
    
36.                     arrResult(1, Record) = arr(i, 1)
    
37.                     arrResult(2, Record) = arr(i, 2)
    
38.                     arrResult(3, Record) = Temp(j)
    
39.                 Next
    
40.             Else
    
41.                 If Len(Tempstr) = 0 Then
    
42.                     Record = Record + 1
    
43.                     ReDim Preserve arrResult(1 To 3, 1 To Record)
    
44.                     arrResult(1, Record) = arr(i, 1)
    
45.                     arrResult(2, Record) = arr(i, 2)
    
46.                     arrResult(3, Record) = arr(i, 3)
    
47.                 Else
    
48. 
    
49.                     Temp = Split(Tempstr, ",")
    
50.                     For j = LBound(Temp) To UBound(Temp)
    
51.                         Record = Record + 1
    
52.                         ReDim Preserve arrResult(1 To 3, 1 To Record)
    
53.                         arrResult(1, Record) = arr(i, 1)
    
54.                         arrResult(2, Record) = arr(i, 2)
    
55.                         arrResult(3, Record) = Temp(j)
    
56.                     Next
    
57. 
    
58.                 End If
    
59.             End If
    
60.         Next
    
61.     End With
    
62.     Worksheets.Add
    
63.     Range("a1").Resize(Record, 3) = WorksheetFunction.Transpose(arrResult)
    
64.     With Columns("a:c")
    
65.         .HorizontalAlignment = xlLeft
    
66.         .AutoFit
    
67.     End With
    
68.     Application.ScreenUpdating = True
    
69.     t = Timer - t
    
70.     MsgBox "转化完成, 用时一共 " & t & "秒"
    
71. End Sub

复制代码

能做出这个表的，绝对是人才。

hoogle

1. Sub hoogle()
   
2. Sheets("原表").Select
   
3. Dim arr, i, j, regex, Sr, Temp, m, Result(1 To 60000, 1 To 3)
   
4. Set regex = CreateObject("VBScript.RegExp")
   
5. arr = Range("a2:c" & Range("a65536").End(3).Row)
   
6. For i = 1 To UBound(arr)
   
7.     Sr = arr(i, 3)
   
8.     If InStr(arr(i, 3), ".") Or InStr(arr(i, 3), ",") Or InStr(arr(i, 3), "，") Then
   
9.     With regex
   
10.         .Global = True
    
11.         .Pattern = "[\u4e00-\u9fa5A-z\（-\）\(-\)\s1-999999]+"
    
12.          Set Temp = .Execute(Sr)
    
13.             For Each m In Temp
    
14.               If Asc(Right(m, 1)) >= 48 And Asc(Right(m, 1)) <= 57 Then m = Left(m, Len(m) - 1)
    
15.               If Len(m) > 1 Then
    
16.                 j = j + 1
    
17.                 Result(j, 1) = arr(i, 1): Result(j, 2) = arr(i, 2): Result(j, 3) = m
    
18.               End If
    
19.             Next m
    
20.     End With
    
21.     Else
    
22.     With regex
    
23.         .Global = True
    
24.         .Pattern = "[\u4e00-\u9fa5A-z\（-\）\(-\)\s]+"
    
25.          Set Temp = .Execute(Sr)
    
26.             For Each m In Temp
    
27.               If Asc(Right(m, 1)) >= 48 And Asc(Right(m, 1)) <= 57 Then m = Left(m, Len(m) - 1)
    
28.               If Len(m) > 1 Then
    
29.                 j = j + 1
    
30.                 Result(j, 1) = arr(i, 1): Result(j, 2) = arr(i, 2): Result(j, 3) = m
    
31.               End If
    
32.             Next m
    
33.     End With
    
34.     End If
    
35. Next
    
36. Sheets.Add
    
37. Range("a1").Resize(60000, 3) = Result
    
38. End Sub
    

复制代码

hoogle

提取单元格的数据并对其-hoogle.zip (64.41 KB, 下载次数: 7)

2013-1-28 21:24 上传

点击文件名下载附件
按附件按钮即可，情况太多，没考虑完全，楼主看下现在的答案是否会有帮助？

wfykhgmqtdh

hoogle 发表于 2013-1-28 21:25
按附件按钮即可，情况太多，没考虑完全，楼主看下现在的答案是否会有帮助？

非常感谢您的帮助