[發問] 儲存格內有函數，但想要手動輸入時會讓原有函數不見

j88141

儲存格內有函數，但想要手動輸入時會讓原有函數不見
還有交叉比對的問題
請問要怎麼改才好
希望用VBA(其他方法也可以)
當然能解決最好
附圖說明，希望大家會比較清楚

        工作表 1                                                                          工作表2                              

下載 (46.94 KB)

2014-4-4 15:15

      

下載 (51.69 KB)

2014-4-4 15:15

     

                 工作表3

下載 (79.31 KB)

2014-4-4 15:24

活頁簿1.rar (12.74 KB)

下載次數: 6

2014-4-4 15:25

蝕光迴狼

回復 1# j88141



1.新增【工作表】名稱更為【資料庫】

2.請使用【名稱定義】，定義【代號】【種類】【姓名】
　　【代號】參照的公式：=OFFSET(資料庫!$A$1,,,COUNTA(資料庫!$AA),)
　　【種類】參照的公式：=OFFSET(資料庫!$B$1,,,COUNTA(資料庫!$BB),)
　　【姓名】參照的公式：=OFFSET(資料庫!$C$1,,,COUNTA(資料庫!$CC),)

******　以上輸入完成後，就算有增加筆數資料，【名稱定義】也會自動更新資料庫

3.再使用【資料驗證】=> 清單
　　【來源】公式：=代號
　　【來源】公式：=種類
　　【來源】公式：=姓名

4.詳情請看附件(用你給的表格修改的)

luhpro

儲存格內有函數，但想要手動輸入時會讓原有函數不見
還有交叉比對的問題
請問要怎麼改才好
希望用VBA(其 ...
j88141 發表於 2014-4-4 15:21

Module1 :

1. Public v11, v12, v21, v22

複製代碼

Workbook :

1. Private Sub Workbook_Open()
   
2.   Dim vA
   
3.   Dim rSou As Range, rTar As Range
   
4.   
   
5.   Set v11 = CreateObject("Scripting.Dictionary")
   
6.   Set v12 = CreateObject("Scripting.Dictionary")
   
7.   Set v21 = CreateObject("Scripting.Dictionary")
   
8.   Set v22 = CreateObject("Scripting.Dictionary")
   
9.   
   
10.   Set rSou = Sheets("工作表1").Range("A:A").SpecialCells(xlCellTypeConstants)
    
11.   For Each rTar In rSou
    
12.     If rTar <> "" And Left(rTar, 2) <> "星期" Then v11(CStr(rTar)) = 1
    
13.   Next
    
14.   
    
15.   Set rSou = Sheets("工作表1").Range("C:C").SpecialCells(xlCellTypeConstants)
    
16.   For Each rTar In rSou
    
17.     If rTar <> "" And Left(rTar, 2) <> "星期" Then v12(CStr(rTar)) = 1
    
18.   Next
    
19. 
    
20.   Set rSou = Sheets("工作表2").Range("A:A").SpecialCells(xlCellTypeConstants)
    
21.   For Each rTar In rSou
    
22.     If rTar <> "代號" Then
    
23.       v21(CStr(rTar)) = rTar.Offset(, 1)
    
24.       v22(CStr(rTar)) = rTar.Offset(, 2)
    
25.     End If
    
26.   Next
    
27. End Sub

複製代碼

工作表3 :

1. Private Sub Worksheet_Change(ByVal Target As Range)
   
2.   Dim bNFind As Boolean
   
3.   
   
4.   With Target
   
5.     If .Count = 1 Then
   
6.       If .Row = 1 Then ' A1 或 B1
   
7.         bNFind = True
   
8.         Select Case .Column
   
9.         
   
10.         Case 1
    
11.           If v11.exists(CStr(v22(CStr(Target)))) Then
    
12.             .Offset(1) = v21(CStr(Target))
    
13.             .Offset(2) = v22(CStr(Target))
    
14.             bNFind = False
    
15.           End If
    
16. 
    
17.         
    
18.         Case 2
    
19.           If v12.exists(CStr(v22(CStr(Target)))) Then
    
20.             .Offset(1) = v21(CStr(Target))
    
21.             .Offset(2) = v22(CStr(Target))
    
22.             bNFind = False
    
23.           End If
    
24.         
    
25.         Case Else
    
26.            bNFind = False
    
27.            
    
28.         End Select
    
29.         
    
30.         If bNFind Then
    
31.           MsgBox v22(CStr(Target)) & " 沒有排班"
    
32.           .Resize(3).ClearContents
    
33.           .Select
    
34.         End If
    
35.       End If
    
36.     End If
    
37.   End With
    
38. End Sub

複製代碼

活頁簿1-a.zip (19.91 KB)

下載次數: 3

2014-10-14 23:54

GBKEE

回復 3# luhpro
請參考一下

1. Option Explicit
   
2. Private Sub Worksheet_Change(ByVal Target As Range)
   
3.     Dim bNFind As Range
   
4.     With Target
   
5.         If .Count = 1 Then
   
6.             If .Row = 1 And .Column <= 7 Then  ' A1 或 B1(星期一 到 星期日)
   
7.                 .Range("A2").Resize(2) = ""
   
8.                 .Range("A3").Validation.Delete
   
9.                 If .Value = "" Then Exit Sub
   
10.                 Application.EnableEvents = False
    
11.                 Set bNFind = Sheets("工作表2").Range("A:A").Find(.Value, LookAT:=xlWhole)
    
12.                 If Not bNFind Is Nothing Then
    
13.                     .Offset(1) = bNFind.Range("B1")
    
14.                     If 排班(bNFind.Range("C1"), Target) Then .Offset(2) = bNFind.Range("C1") & vbLf & "沒有排班"
    
15.                 End If
    
16.                 Application.EnableEvents = True
    
17.             End If
    
18.         End If
    
19.     End With
    
20. End Sub
    
21. Private Function 排班(ByVal T1 As Range, T2 As Range) As Boolean
    
22.     Dim bNFind As Range, S As String
    
23.     With Sheets("工作表1")
    
24.         Set bNFind = .Columns(T2.Column).Find(T1, LookAT:=xlWhole)
    
25.         If Not bNFind Is Nothing Then
    
26.             For Each bNFind In .Columns(T2.Column).SpecialCells(xlCellTypeConstants)
    
27.                 If bNFind.Row > 1 And bNFind <> "" Then
    
28.                     S = IIf(S <> "", S & "," & bNFind, bNFind)
    
29.                 End If
    
30.             Next
    
31.         Else
    
32.            排班 = True
    
33.         End If
    
34.         With T2.Range("A3")
    
35.             If Not 排班 Then
    
36.                 .Validation.Add Type:=xlValidateList, Formula1:=S
    
37.                 .Value = T1
    
38.             End If
    
39.         End With
    
40.     End With
    
41. End Function

複製代碼