- 帖子
- 33
- 主題
- 10
- 精華
- 0
- 積分
- 59
- 點名
- 0
- 作業系統
- win10
- 軟體版本
- office 2013
- 閱讀權限
- 20
- 性別
- 男
- 註冊時間
- 2013-3-10
- 最後登錄
- 2024-2-7
 
|
4#
發表於 2014-12-22 08:45
| 只看該作者
抱歉! 沒注意您的權限
將G1輸入數字即可啟動程式
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = "$G$1" Then
Dim I As Long
Dim J As Long
Application.ScreenUpdating = False
Call LASTCell(J)
For I = 2 To J
If Len(Sheets("SHEET1").Range("C" & I)) = 18 Or Right(Sheets("SHEET1").Range("C" & I), 1) = "N" Then
Sheets("SHEET1").Range("D" & I) = "新"
End If
If Len(Sheets("SHEET1").Range("C" & I)) = 15 Then
Sheets("SHEET1").Range("D" & I) = "舊"
If Sheets("SHEET1").Range("A" & I) <> Sheets("SHEET1").Range("A" & I + 1) Then
Call INSERT(I)
Sheets("SHEET1").Range("A" & I + 1 & ":D" & I + 1).Value = Sheets("SHEET1").Range("A" & I & ":D" & I).Value
Sheets("SHEET1").Range("C" & I + 1) = Left(Sheets("SHEET1").Range("C" & I), 6) & "19" & Right(Sheets("SHEET1").Range("C" & I), 9) & "N"
Sheets("SHEET1").Range("D" & I + 1) = "新"
I = I + 1
J = J + 1
End If
End If
Next
End If
End Sub
Sub LASTCell(J As Long)
With Sheets("SHEET1").Range("A:A")
Set X = .Find(What:="", After:=.Cells(.Cells.Count), _
LookIn:=xlValues, LookAt:=xlWhole, SearchDirection:=xlNext)
If Not X Is Nothing Then J = X.Row + 2
End With
End Sub
Sub INSERT(I As Long)
'
Rows(I + 1 & ":" & I + 1).Select
Selection.INSERT Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
End Sub |
-
-
執行前.jpg
(211.91 KB)
-
-
執行後.jpg
(219.54 KB)
|
