Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Not Intersect(Target(1), Range("C1:IV1")) Is Nothing Then
If Target(1) <> "" Then 複製
End If
If Not Intersect(Target(1), Range("C2:IV2")) Is Nothing Then
If Target(1) <> "" Then 刪除
End If
End Sub
---------------------------------------------------------------------------------------------------------
Sub 複製()
Again:
ZZ = Application.InputBox("請輸入列數", "請輸入複製所需欄數", 10, Type:=2)
If ZZ = "" Or ZZ = False Then End
If ZZ <= 1 Then
MsgBox "欄數不得小於１列！！！", , "欄數錯誤請重新輸入 ！！"
GoTo Again
End If
[G1:P360].Copy Sheet2.Range("IV1").End(xlToLeft).Offset(0, 1)
End Sub
---------------------------------------------------------------------------------------------------------
Sub 刪除()
Dim F
Again:
ZZ = Application.InputBox("請輸入列數", "請輸入刪除所需欄數", 10, Type:=2)
If ZZ = "" Or ZZ = False Then End
If ZZ <= 1 Then
MsgBox "欄數不得小於１列！！！", , "欄數錯誤請重新輸入 ！！"
GoTo Again
End If
If Sheet1.[C1] = "" Then Exit Sub
Columns("D:M").Delete Shift:=xlToLefte
End Sub作者: myleoyes 時間: 2011-1-3 21:04
回復 2#mistery
各位前輩你們好!
這個問題的程式終於拼湊完成
Sub 複製()
Dim F As Range, A As Range
Again:
ZZ = Application.InputBox("請輸入列數", "請輸入複製所需欄數", 10, Type:=2)
If ZZ = "" Or ZZ = False Then End
Range("B1") = ZZ
If ZZ <= 1 Then
MsgBox "欄數不得小於１列！！！", , "欄數錯誤請重新輸入 ！！"
GoTo Again
End If
With ActiveSheet
Set F = .Rows(1).Cells.Find(.Cells(1, ActiveCell.Column))
Set F = .Range(F.Offset(0), F.Offset(0, ZZ).End(xlDown))
End With
Set A = Sheet2.[IV1].End(xlToLeft).Offset(, 1)
F.Copy A
End Sub
Sub 刪除()
Again:
ZZ = Application.InputBox("請輸入列數", "請輸入複製所需欄數", 10, Type:=2)
If ZZ = "" Or ZZ = False Then End
Range("B1") = ZZ
If ZZ <= 1 Then
MsgBox "欄數不得小於１列！！！", , "欄數錯誤請重新輸入 ！！"
GoTo Again
End If
With ActiveSheet
Set F = .Rows(1).Cells.Find(.Cells(1, ActiveCell.Column))
Set F = .Range(F.Offset(0), F.Offset(0, ZZ).End(xlDown))
End With
F.Delete
End Sub
謝謝大家!!
