改變來源檔

myleoyes

各位前輩你們好!!   
         問題如附檔說明
         請知道的前輩,不吝賜教謝謝再三!!

GBKEE

回復 1# myleoyes
試試看

1. Sub 插入()
   
2.     Dim R As Range, S As String
   
3.     Set R = ActiveCell
   
4.     If R.Column >= 1 And R.Column <= 17 Then
   
5.         If R.Row > 1 And Cells(Rows.Count, R.Column).End(xlUp).Row >= R.Row Then
   
6.             With Range("A" & R.Row + 1 & ":Q" & R.Row + 1)
   
7.                 .Insert
   
8.                 End With
   
9.             With Range("A" & R.Row & ":Q" & R.Row)
   
10.                 .Copy .Offset(1, 0)
    
11.             End With
    
12.         End If
    
13.     End If
    
14.     With ActiveCell
    
15.         .Offset(1, 0) = Date
    
16. ag:
    
17.      ZZ = Application.InputBox("請輸入名稱", "        輸入新增名稱", Selection.Offset(1, 3), Type:=2)
    
18.      If ZZ = False Then GoTo ag
    
19.         .Offset(1, 3) = ZZ
    
20. ag1:
    
21.      ZZ = Application.InputBox("請輸入數字", "        輸入儲存格位子", Type:=1)
    
22.      If ZZ = False Then GoTo ag1
    
23.         S = "='" & ThisWorkbook.Path & "\[" & .Offset(1, 3) & ".xls]Sheet1'!$C$" & ZZ
    
24.         .Offset(1, 8) = S
    
25.         S = "=IF(RC[5]="""",LOOKUP(9.9E+307,'" & ThisWorkbook.Path & "\[" & .Offset(1, 3) & ".xls]Sheet1'!C2),RC[5])"
    
26.         .Offset(1, 9) = S
    
27.     End With
    
28. End Sub

複製代碼

myleoyes

回復 2# GBKEE
良師!謝謝!!
        再麻煩看看這個檔案謝謝再三!!

GBKEE

回復 3# myleoyes

1. Sub 尋找()
   
2.     Dim Rng As Range, F1, F2
   
3.     With Sheet2.Range("D:D")
   
4.         If Not IsError(Application.Match(Sheet6.[E1], .Cells, 0)) Then
   
5.             .Replace Sheet6.[E1], "=XXX", xlWhole
   
6.             Set Rng = .SpecialCells(xlCellTypeFormulas, xlErrors)
   
7.             Rng.Cells = Sheet6.[E1]
   
8.             F1 = Application.Match(Sheet6.[F1], Rng.Offset(, 3), 0)
   
9.             F2 = Application.Match(Sheet6.[G1], Rng.Offset(, 5), 0)
   
10.             If Not IsError(F1) And Not IsError(F2) Then
    
11.                  If F1 = F2 Then Rng(F1, 2).Select
    
12.                  If F1 <> F2 Then Rng(Rng.Rows.Count, 2).Select
    
13.             Else
    
14.                 Rng(Rng.Rows.Count, 2).Select
    
15.             End If
    
16.         Else
    
17.             .Parent.Range("A" & .Parent.Rows.Count).End(xlUp).Offset(1).Select
    
18.         End If
    
19.     End With
    
20. End Sub

複製代碼

myleoyes

回復 4# GBKEE
良師!  
程式程序都對,但是小弟加入程式後
卻無法執行出現錯誤
如附檔所示請再麻煩修改
辛苦囉!謝謝再三!!

GBKEE

回復 5# myleoyes

1. Private Sub Worksheet_SelectionChange(ByVal Target As Range)
   
2.     Select Case Target(1).Address(0, 0)
   
3.         Case "A1"
   
4.            ActiveWindow.ScrollColumn = 1
   
5.     End Select
   
6.     With Target(1)
   
7.         If .Column = 1 Then
   
8.             If (.Row >= 3 And .Row <= 12) And Target(1) <> "" Then  '**********
   
9.                 插入刪除
   
10.             End If
    
11.        End If
    
12.     End With
    
13. End Sub

複製代碼

或是如此

1. Sub 尋找()
   
2.     Dim Rng As Range, F1, F2
   
3.     With Sheet2.Range("D:D")
   
4.         If Not IsError(Application.Match(Sheet6.[E1], .Cells, 0)) Then
   
5.             Application.EnableEvents = False '*************
   
6.             .Replace Sheet6.[E1], "=XXX", xlWhole
   
7.             Set Rng = .SpecialCells(xlCellTypeFormulas, xlErrors)
   
8.             Rng.Cells = Sheet6.[E1]
   
9.             F1 = Application.Match(Sheet6.[F1], Rng.Offset(, 3), 0)
   
10.             F2 = Application.Match(Sheet6.[G1], Rng.Offset(, 5), 0)
    
11.             If Not IsError(F1) And Not IsError(F2) Then
    
12.                  If F1 = F2 Then Rng(F1, 2).Select
    
13.                  If F1 <> F2 Then Rng(Rng.Rows.Count, 2).Select
    
14.             Else
    
15.                 Rng(Rng.Rows.Count, 2).Select
    
16.             End If
    
17.             Application.EnableEvents = True    ''*************
    
18.         Else
    
19.             .Parent.Range("A" & .Parent.Rows.Count).End(xlUp).Offset(1).Select
    
20.         End If
    
21.     End With
    
22. End Sub

複製代碼

myleoyes

回復 6# GBKEE
良師!  
         辛苦囉!謝謝再三!!

myleoyes

回復 6# GBKEE
良師!  
       程式凸槌如附檔說明
       請再麻煩修改辛苦囉!謝謝再三!!

GBKEE

回復 8# myleoyes
改成如此

1. Sub 尋找()
   
2.     Dim Rng As Range, E As Range, Msg As Boolean
   
3.     With Sheet2.Range("D:D")
   
4.         If Not IsError(Application.Match(Sheet6.[E1], .Cells, 0)) Then
   
5.             Application.EnableEvents = False
   
6.             .Replace Sheet6.[E1], "=XXX", xlWhole
   
7.             Set Rng = .SpecialCells(xlCellTypeFormulas, xlErrors)
   
8.             Rng.Cells = Sheet6.[E1]
   
9.             For Each E In Rng.Offset(, 3)
   
10.                 If E = Sheet6.[F1] And E.Offset(, 2) = Sheet6.[G1] Then
    
11.                     E.Offset(, -2).Select
    
12.                     Msg = True
    
13.                     Exit For
    
14.                 End If
    
15.             Next
    
16.             If Msg = False Then Rng(Rng.Rows.Count, 2).Select
    
17.             
    
18.             
    
19.             Application.EnableEvents = True
    
20.         Else
    
21.             .Parent.Range("A" & .Parent.Rows.Count).End(xlUp)(0, 1).Offset(1).Select
    
22.         End If
    
23.     End With
    
24. End Sub

複製代碼

myleoyes

回復 9# GBKEE
良師!
       辛苦囉!謝謝再三!!