- 帖子
- 976
- 主題
- 7
- 精華
- 0
- 積分
- 1018
- 點名
- 0
- 作業系統
- Win10
- 軟體版本
- Office 2016
- 閱讀權限
- 50
- 性別
- 男
- 註冊時間
- 2013-4-19
- 最後登錄
- 2024-12-18
|
2#
發表於 2021-4-16 13:45
| 只看該作者
回復 1# q1a2z5
請測試看看，謝謝。
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 |
|
