標題:
[發問]
儲存格內有函數，但想要手動輸入時會讓原有函數不見
[打印本頁]
作者:
j88141
時間:
2014-4-4 15:21
標題:
儲存格內有函數，但想要手動輸入時會讓原有函數不見
本帖最後由 j88141 於 2014-4-4 15:25 編輯
儲存格內有函數，但想要手動輸入時會讓原有函數不見
還有交叉比對的問題
請問要怎麼改才好
希望用VBA(其他方法也可以)
當然能解決最好
附圖說明，希望大家會比較清楚
工作表 1 工作表2
[attach]17937[/attach] [attach]17938[/attach]
工作表3
[attach]17939[/attach]
[attach]17940[/attach]
作者:
蝕光迴狼
時間:
2014-10-7 23:00
回復
1#
j88141
1.新增【工作表】名稱更為【資料庫】
2.請使用【名稱定義】，定義【代號】【種類】【姓名】
【代號】參照的公式：=OFFSET(資料庫!$A$1,,,COUNTA(資料庫!$A
A),)
【種類】參照的公式：=OFFSET(資料庫!$B$1,,,COUNTA(資料庫!$B
B),)
【姓名】參照的公式：=OFFSET(資料庫!$C$1,,,COUNTA(資料庫!$C
C),)
****** 以上輸入完成後，就算有增加筆數資料，【名稱定義】也會自動更新資料庫
3.再使用【資料驗證】=> 清單
【來源】公式：=代號
【來源】公式：=種類
【來源】公式：=姓名
4.詳情請看附件(用你給的表格修改的)
作者:
luhpro
時間:
2014-10-14 23:54
儲存格內有函數，但想要手動輸入時會讓原有函數不見
還有交叉比對的問題
請問要怎麼改才好
希望用VBA(其 ...
j88141 發表於 2014-4-4 15:21
Module1 :
Public v11, v12, v21, v22
複製代碼
Workbook :
Private Sub Workbook_Open()
Dim vA
Dim rSou As Range, rTar As Range
Set v11 = CreateObject("Scripting.Dictionary")
Set v12 = CreateObject("Scripting.Dictionary")
Set v21 = CreateObject("Scripting.Dictionary")
Set v22 = CreateObject("Scripting.Dictionary")
Set rSou = Sheets("工作表1").Range("A:A").SpecialCells(xlCellTypeConstants)
For Each rTar In rSou
If rTar <> "" And Left(rTar, 2) <> "星期" Then v11(CStr(rTar)) = 1
Next
Set rSou = Sheets("工作表1").Range("C:C").SpecialCells(xlCellTypeConstants)
For Each rTar In rSou
If rTar <> "" And Left(rTar, 2) <> "星期" Then v12(CStr(rTar)) = 1
Next
Set rSou = Sheets("工作表2").Range("A:A").SpecialCells(xlCellTypeConstants)
For Each rTar In rSou
If rTar <> "代號" Then
v21(CStr(rTar)) = rTar.Offset(, 1)
v22(CStr(rTar)) = rTar.Offset(, 2)
End If
Next
End Sub
複製代碼
工作表3 :
Private Sub Worksheet_Change(ByVal Target As Range)
Dim bNFind As Boolean
With Target
If .Count = 1 Then
If .Row = 1 Then ' A1 或 B1
bNFind = True
Select Case .Column
Case 1
If v11.exists(CStr(v22(CStr(Target)))) Then
.Offset(1) = v21(CStr(Target))
.Offset(2) = v22(CStr(Target))
bNFind = False
End If
Case 2
If v12.exists(CStr(v22(CStr(Target)))) Then
.Offset(1) = v21(CStr(Target))
.Offset(2) = v22(CStr(Target))
bNFind = False
End If
Case Else
bNFind = False
End Select
If bNFind Then
MsgBox v22(CStr(Target)) & " 沒有排班"
.Resize(3).ClearContents
.Select
End If
End If
End If
End With
End Sub
複製代碼
[attach]19344[/attach]
作者:
GBKEE
時間:
2014-10-15 09:17
本帖最後由 GBKEE 於 2014-10-15 09:19 編輯
回復
3#
luhpro
請參考一下
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim bNFind As Range
With Target
If .Count = 1 Then
If .Row = 1 And .Column <= 7 Then ' A1 或 B1(星期一 到 星期日)
.Range("A2").Resize(2) = ""
.Range("A3").Validation.Delete
If .Value = "" Then Exit Sub
Application.EnableEvents = False
Set bNFind = Sheets("工作表2").Range("A:A").Find(.Value, LookAT:=xlWhole)
If Not bNFind Is Nothing Then
.Offset(1) = bNFind.Range("B1")
If 排班(bNFind.Range("C1"), Target) Then .Offset(2) = bNFind.Range("C1") & vbLf & "沒有排班"
End If
Application.EnableEvents = True
End If
End If
End With
End Sub
Private Function 排班(ByVal T1 As Range, T2 As Range) As Boolean
Dim bNFind As Range, S As String
With Sheets("工作表1")
Set bNFind = .Columns(T2.Column).Find(T1, LookAT:=xlWhole)
If Not bNFind Is Nothing Then
For Each bNFind In .Columns(T2.Column).SpecialCells(xlCellTypeConstants)
If bNFind.Row > 1 And bNFind <> "" Then
S = IIf(S <> "", S & "," & bNFind, bNFind)
End If
Next
Else
排班 = True
End If
With T2.Range("A3")
If Not 排班 Then
.Validation.Add Type:=xlValidateList, Formula1:=S
.Value = T1
End If
End With
End With
End Function
複製代碼
歡迎光臨 麻辣家族討論版版 (http://forum.twbts.com/)
A),)B),)C),)