数据转换的问题

ailvlv

请教各位老师：
能不能用VBA实现根据“原始数据”表中数据生成“生成”表中的样式，谢谢了！~~ 数据转换的问题.rar (2.67 KB, 下载次数: 9)

2017-6-23 22:49 上传

点击文件名下载附件

idnoidno

1. Option Explicit
   
2. Sub ta()
   
3. Dim arr, brr
   
4. Dim sh1 As Worksheet, sh2 As Worksheet
   
5. Dim i As Long, j As Long, k As Long
   
6. Set sh1 = Worksheets("原始數據")
   
7. Set sh2 = Worksheets("生成")
   
8. sh1.Select
   
9. arr = Range("b2:d" & Cells(Rows.Count, 1).End(xlUp).Row)
   
10. ReDim brr(1 To UBound(arr, 1) * 3 + 1, 1 To 2)
    
11. k = 1
    
12. For i = 1 To UBound(arr)
    
13.         For j = 1 To 3
    
14.             If arr(i, j) <> "" Then
    
15.                 brr(k, 1) = arr(i, j)
    
16.                 sh2.Cells(k + 1, 1) = sh1.Cells(i + 1, 1)
    
17.                 k = k + 1
    
18.             End If
    
19.         Next j
    
20. Next i
    
21. With sh2
    
22. On Error Resume Next
    
23.     .Range("a1:b1") = sh1.Range("a1:b1").Value
    
24.     .[b2].Resize(UBound(brr, 1), UBound(brr, 2)) = brr
    
25.     For i = 2 To .Cells(.Rows.Count, 1).End(xlUp).Row - 1
    
26.         If .Cells(i + 1, 1) = .Cells(i, 1) Then
    
27.             .Range(Cells(i, 1), Cells(i + 1, 1)).Merge
    
28.         End If
    
29.     Next i
    
30. End With
    
31. Set sh1 = Nothing
    
32. Set sh2 = Nothing
    
33. 
    
34. End Sub

复制代码

精英土豪

Sub 试试看()
arr = Sheets(2).UsedRange
n = 1
Cells(n, 5) = arr(1, 1)
Cells(n, 6) = arr(1, 2)
    For 行号 = 2 To UBound(arr)
        For 列号 = 2 To UBound(arr, 2)
            If arr(行号, 列号) <> "" Then
                n = n + 1
                Cells(n, 5) = arr(行号, 1)
                Cells(n, 6) = arr(行号, 列号)
            End If
        Next
    Next
End Sub
我不支持合并单元格，除非你是报表

grf1973

1. Sub tt()
   
2.     arr = Sheets("原始数据").[a1].CurrentRegion
   
3.     ReDim brr(1 To UBound(arr) * UBound(arr, 2), 1 To 2)
   
4.     [a2:b1000].Clear   '清除内容及格式
   
5.     For i = 2 To UBound(arr)
   
6.         For j = 2 To UBound(arr, 2)
   
7.             If arr(i, j) <> "" Then
   
8.                 n = n + 1
   
9.                 brr(n, 1) = arr(i, 1)
   
10.                 brr(n, 2) = arr(i, j)
    
11.                 If n > 1 Then If brr(n, 1) = brr(n - 1, 1) Then Cells(n, 1).Resize(2).Merge   '相同序号合并单元格
    
12.             End If
    
13.         Next
    
14.     Next
    
15.     [a2].Resize(n, 2) = brr
    
16. End Sub
    

复制代码