数据表转置VBA请教

baofa2

1. Sub test0()
   
2.   
   
3.   Dim strFullName As String
   
4.   
   
5.   strFullName = ThisWorkbook.Path & "\初始数据.xlsx"
   
6.   If Dir(strFullName) = "" Then MsgBox "!?", 64: Exit Sub
   
7.   
   
8.   Application.ScreenUpdating = False
   
9.   
   
10.   Dim ar(1 To 1000, 1 To 4), br
    
11.   Dim i As Long, j As Long, k As Long, cnt As Long
    
12.   
    
13.   With Workbooks.Open(strFullName, 0)
    
14.     br = .Worksheets(1).Range("A1").CurrentRegion
    
15.     .Close False
    
16.   End With
    
17.   
    
18.   cnt = 1
    
19.   For j = 1 To UBound(ar, 2)
    
20.     ar(cnt, j) = Split("单位 当天巡检日期 巡检项 巡检项时间")(j - 1)
    
21.   Next
    
22.   
    
23.   For i = 2 To UBound(br)
    
24.     ar(cnt + 1, 1) = br(i, 43)
    
25.     ar(cnt + 1, 2) = br(i, 42)
    
26.     For j = 5 To UBound(br, 2) - 2
    
27.       If Right(br(1, j), 2) = "时间" Then
    
28.         If Right(br(1, j + 1), 3) = "巡检项" Then
    
29.           cnt = cnt + 1
    
30.           ar(cnt, 3) = br(i, j + 1)
    
31.           ar(cnt, 4) = br(i, j)
    
32.         End If
    
33.       End If
    
34.     Next
    
35.   Next
    
36.   
    
37.   With Range("A1")
    
38.     .CurrentRegion.Clear
    
39.     .Resize(cnt, UBound(ar, 2)) = ar
    
40.     For i = cnt To 2 Step -1
    
41.       k = k + 1
    
42.       If Len(ar(i, 1)) Then
    
43.         For j = 0 To 1
    
44.           .Offset(i - 1, j).Resize(k).Merge
    
45.         Next
    
46.         k = 0
    
47.       End If
    
48.     Next
    
49.     .CurrentRegion.Borders.LineStyle = xlContinuous
    
50.   End With
    
51.   
    
52.   Application.ScreenUpdating = True
    
53.   Beep
    
54. End Sub

复制代码