Sub tt()
Dim Arr, Brr(1 To 13, 1 To 1), T, T2, i%, j%, Y%, N%, N1%
Y = 3
For sh = 2 To Sheets.Count
With Sheets(sh).Range("A4:G12")
Arr = .Value
For i = 1 To 4
For j = 2 To UBound(Arr, 2)
If InStr(Arr(i, j), "月") = False Then GoTo 98
T = Mid(Arr(i, j), 1, Len(Arr(i, j)) - 1): T2 = Arr(i + 1, j)
If T2 <> "" Then N = N + 1: Brr(T + 1, 1) = T2
98: Next j
Next i
If N > 0 Then
Brr(1, 1) = Sheets(sh).Name
Sheets("輸入表").Cells(2, Y).Resize(13, 1) = Brr
Erase Brr
End If
For i = 5 To 8
For j = 2 To UBound(Arr, 2)
If InStr(Arr(i, j), "月") = False Then GoTo 99
T = Mid(Arr(i, j), 1, Len(Arr(i, j)) - 1): T2 = Arr(i + 1, j)
If T2 <> "" Then N1 = N1 + 1: Brr(T + 1, 1) = T2
99: Next j
Next i
If N1 > 0 Then
Brr(1, 1) = Sheets(sh).Name
Sheets("輸入表").Cells(16, Y).Resize(13, 1) = Brr
Erase Brr
End If
If N > 0 Or N1 > 0 Then N = 0: N1 = 0: Y = Y + 1
End With
Next
End Sub作者: q1a2z5 時間: 2021-4-16 14:23
Sub tt()
Dim Arr, Ar(1 To 1, 1 To 6), Ar2(1 To 1, 1 To 6), Ar3(1 To 1, 1 To 6)
Dim Ar4(1 To 1, 1 To 6), T$, j&, i&, N%
Application.ScreenUpdating = False
Tm = Timer
Arr = Sheets("輸入表").Range("a1:bb" & [輸入表!B65536].End(3).Row) '資料裝入數組
For j = 3 To UBound(Arr, 2) '從第3欄開始到最後
T = Arr(2, j) '年度
If T = "" Then GoTo 99 '如果年度空白就換下個
For i = 3 To 8: N = N + 1: Ar(1, N) = Arr(i, j): Next: N = 0 '109年1-6月資料裝入Ar數組
For i = 9 To 14: N = N + 1: Ar2(1, N) = Arr(i, j): Next: N = 0 '109年7-12月資料裝入Ar2數組
For i = 17 To 22: N = N + 1: Ar3(1, N) = Arr(i, j): Next: N = 0 '110年1-6月資料裝入Ar3數組
For i = 23 To 28: N = N + 1: Ar4(1, N) = Arr(i, j): Next: N = 0 '110年7-12月資料裝入Ar4數組
With Sheets(T) '每個年度sheet
.Range("B5").Resize(1, 6) = Ar 'Ar資料貼至B5
.Range("B7").Resize(1, 6) = Ar2 'Ar2資料貼至B7
.Range("B9").Resize(1, 6) = Ar3 'Ar3資料貼至B9
.Range("B11").Resize(1, 6) = Ar4 'Ar4資料貼至B11
End With
99: Next
Application.ScreenUpdating = True
MsgBox "執行完成" & Timer - Tm & " 秒"
End Sub作者: ML089 時間: 2021-4-29 13:38
