求大神帮忙，VBA多数组自动抓取成多列

cndxm

求大神帮忙，VBA多数组自动抓取成多列，Sheet1到Sheet2的效果，谢谢

lsdongjh

1. Sub Test()
   
2.     Dim shSource As Worksheet, shResult As Worksheet, arr As Variant
   
3.     Dim rgResult As Range, strTemp As String, strSplit() As String
   
4.     Dim lngRow As Long, lngCol As Long
   
5.     Dim objDic As Object, strKey As String, strItem As String
   
6.    
   
7.     Set shSource = Sheets("Sheet1")
   
8.     Set shResult = Sheets("Sheet2")
   
9. 
   
10.     strTemp = shSource.UsedRange.Address(0, 0)
    
11.     strTemp = Split(strTemp, ":")(1)
    
12.     arr = shSource.Range("B2:" & strTemp)
    
13.     Set objDic = CreateObject("Scripting.Dictionary")
    
14.    
    
15.     For lngCol = 2 To UBound(arr, 2)
    
16.         For lngRow = LBound(arr) To UBound(arr)
    
17.             If arr(lngRow, 1) = "S/N" Then
    
18.                 strKey = arr(lngRow, lngCol)
    
19.                 strKey = Trim(strKey)
    
20.             Else
    
21.                 strItem = arr(lngRow, lngCol)
    
22.                 strItem = Trim(strItem)
    
23.                 If strItem <> "" Then objDic(strKey) = objDic(strKey) & "," & strItem
    
24.             End If
    
25.         Next
    
26.     Next
    
27.    
    
28.     Set rgResult = shResult.Range("B2")
    
29.     rgResult.Resize(1, objDic.Count) = objDic.keys
    
30.    
    
31.     arr = rgResult.Resize(1, objDic.Count)
    
32.    
    
33.     For lngCol = LBound(arr, 2) To UBound(arr, 2)
    
34.         strKey = arr(1, lngCol)
    
35.         strItem = objDic(strKey)
    
36.         strTemp = Mid(strItem, 2)
    
37.         strSplit = Split(strTemp, ",")
    
38.         rgResult.Offset(1, lngCol - 1).Resize(UBound(strSplit) + 1, 1) = Application.WorksheetFunction.Transpose(strSplit)
    
39.     Next
    
40.    
    
41.     MsgBox "OK"
    
42. End Sub
    

复制代码

cndxm

朱荣兴 发表于 2018-7-30 12:20
Sub hebing()
ReDim brr(1 To 1000, 1 To 500)
rs = Sheet1.Cells(Rows.Count, 2).End(xlUp).Row

谢谢大神！

cndxm

lsdongjh 发表于 2018-7-30 12:48

谢谢大神！帮我看下附件这种多头多尾格式的要怎么改，谢谢啦！

lsdongjh

数据转换2.rar (29.29 KB, 下载次数: 22)

2018-7-30 16:40 上传

点击文件名下载附件

cndxm

lsdongjh 发表于 2018-7-30 15:32

大神，说是文件损坏，打不开，麻烦看一下，谢谢

lsdongjh

楼上附件已更新：

1. 
   
2. Sub Test()
   
3.     Dim shSource As Worksheet, shResult As Worksheet, arr As Variant
   
4.     Dim rgResult As Range, strTemp As String, strSplit() As String
   
5.     Dim lngRow As Long, lngCol As Long
   
6.     Dim objDic As Object, strKey As String, strItem As String
   
7.     Dim blIsData As Boolean, lngCurRow As Long
   
8.    
   
9.     Set shSource = Sheets("Sheet1")
   
10.     Set shResult = Sheets("Sheet2")
    
11. 
    
12.     strTemp = shSource.UsedRange.Address(0, 0)
    
13.     strTemp = Split(strTemp, ":")(1)
    
14.     arr = shSource.Range("A1:" & strTemp)
    
15.     Set objDic = CreateObject("Scripting.Dictionary")
    
16.    
    
17.     For lngCol = 2 To UBound(arr, 2)
    
18.         For lngRow = 1 To UBound(arr)
    
19.             If arr(lngRow, 1) = "Test" Then
    
20.                 strKey = arr(lngRow, lngCol)
    
21.                 strKey = Trim(strKey)
    
22.             ElseIf arr(lngRow, 1) = "LOT No." Then
    
23.                 blIsData = True
    
24.                 lngCurRow = lngRow
    
25.             ElseIf arr(lngRow, 1) = "" Then
    
26.                 blIsData = False
    
27.             End If
    
28.             
    
29.             If blIsData = True And lngRow > lngCurRow Then
    
30.                 strItem = arr(lngRow, lngCol)
    
31.                 strItem = Trim(strItem)
    
32.                 If strItem <> "" Then objDic(strKey) = objDic(strKey) & "," & strItem
    
33.             End If
    
34.         Next
    
35.     Next
    
36.    
    
37.     Set rgResult = shResult.Range("B2")
    
38.     rgResult.Resize(1, objDic.Count) = objDic.keys
    
39.    
    
40.     arr = rgResult.Resize(1, objDic.Count)
    
41.    
    
42.     For lngCol = LBound(arr, 2) To UBound(arr, 2)
    
43.         strKey = arr(1, lngCol)
    
44.         strItem = objDic(strKey)
    
45.         strTemp = Mid(strItem, 2)
    
46.         strSplit = Split(strTemp, ",")
    
47.         rgResult.Offset(1, lngCol - 1).Resize(UBound(strSplit) + 1, 1) = Application.WorksheetFunction.Transpose(strSplit)
    
48.     Next
    
49.    
    
50.     MsgBox "OK"
    
51. End Sub
    

复制代码

cndxm

lsdongjh 发表于 2018-7-30 16:41
楼上附件已更新：

很强大，谢谢大神！