Board logo

標題: 改變來源檔 [打印本頁]
作者: myleoyes    時間: 2013-9-28 22:22     標題: 改變來源檔

各位前輩你們好!!   
         問題如附檔說明
         請知道的前輩,不吝賜教謝謝再三!!
作者: GBKEE    時間: 2013-9-29 12:50

回復 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    時間: 2013-9-29 15:35

回復 2# GBKEE
良師!謝謝!!
        再麻煩看看這個檔案謝謝再三!!
作者: GBKEE    時間: 2013-9-29 16:40

回復 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    時間: 2013-9-29 20:34

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

回復 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    時間: 2013-9-30 21:52

回復 6# GBKEE
良師!  
         辛苦囉!謝謝再三!!
作者: myleoyes    時間: 2013-10-1 21:43

回復 6# GBKEE
良師!  
       程式凸槌如附檔說明
       請再麻煩修改辛苦囉!謝謝再三!!
作者: GBKEE    時間: 2013-10-2 14:59

回復 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    時間: 2013-10-3 21:07

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



歡迎光臨 麻辣家族討論版版 (http://forum.twbts.com/)