刪除與複製

各位前輩你們好!
      前輩!問題如附檔說明
      請知道的前輩,不吝賜教謝謝再三!!
      小弟在此誠摯的祝各位前輩!
         新年快樂!!事事如意,..

Leov38.rar (18.92 KB)

樓主熱帖

mistery

中學生 Rank: 2

帖子: 82
主題: 5
精華: 0
積分: 115
點名: 0
作業系統: Vista
軟體版本: Office 2003
閱讀權限: 20
性別: 男
來自: Taipei
註冊時間: 2010-5-1
最後登錄: 2023-4-18

2^#

發表於 2011-1-3 17:00 | 只看該作者

本帖最後由 mistery 於 2011-1-3 17:01 編輯

公式在附件寫的VBA裡

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

TOP

myleoyes

高中生 Rank: 3 Rank: 3

帖子: 463
主題: 116
精華: 0
積分: 580
點名: 0
作業系統: Vista
軟體版本: 2007
閱讀權限: 50
性別: 男
註冊時間: 2010-5-4
最後登錄: 2017-11-13

論壇贊助勳章論壇榮譽勳章

3^#

發表於 2011-1-3 21:04 | 只看該作者

回復 2# mistery
mistery前輩你好!
   前輩!謝謝!!這是範例原來的程式
   並不適用的啊!不懂你的用意
   請知道的前輩,不吝賜教謝謝再三!!

TOP

myleoyes

高中生 Rank: 3 Rank: 3

帖子: 463
主題: 116
精華: 0
積分: 580
點名: 0
作業系統: Vista
軟體版本: 2007
閱讀權限: 50
性別: 男
註冊時間: 2010-5-4
最後登錄: 2017-11-13

論壇贊助勳章論壇榮譽勳章

4^#

發表於 2011-1-6 21:35 | 只看該作者

回復 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
      謝謝大家!!

TOP