標題:
[發問]
輸入至不同欄位儲存格來個別找出兩個工作表對應值
[打印本頁]
作者:
luke
時間:
2012-9-20 20:19
標題:
輸入至不同欄位儲存格來個別找出兩個工作表對應值
各位大大
1.Sheet2表和Sheet3表為資料列各有數千筆資料.
2.Sheet1表A:C欄為Sheet2輸出區,而D:G欄為Sheet3輸出區.
3.自A7和D7儲存格往下開始做個別資料輸入,例如:
A7儲存格
作者:
luhpro
時間:
2012-9-22 09:36
各位大大
1.Sheet2表和Sheet3表為資料列各有數千筆資料.
2.Sheet1表A:C欄為Sheet2輸出區,而D:G欄為Shee ...
luke 發表於 2012-9-20 20:19
Module1
Public v2, v3
複製代碼
ThisWorkBook
Private Sub Workbook_Open()
Dim rTar As Range
Set v2 = CreateObject("Scripting.Dictionary")
Set v3 = CreateObject("Scripting.Dictionary")
With Sheets("sheet2")
For Each rTar In .Range(.[A2], .[A2].End(xlDown))
v2(rTar & "") = rTar.Row
Next rTar
End With
With Sheets("sheet3")
For Each rTar In .Range(.[A2], .[A2].End(xlDown))
v3(rTar & "") = rTar.Row
Next rTar
End With
End Sub
複製代碼
Sheet1
Private Sub Worksheet_Change(ByVal Target As Range)
Dim iI%
Dim rTar As Range
Set rTar = Target
With rTar
Select Case .Column
Case 1 ' 區分
With .Parent
For iI = 2 To 3
.Cells(rTar.Row, iI) = Sheets("sheet2").Cells(v2(rTar.Text), iI)
Next iI
End With
Case 4 ' 票號
With .Parent
For iI = 2 To 4
.Cells(rTar.Row, iI + 3) = Sheets("sheet3").Cells(v3(rTar.Text), iI)
Next iI
End With
End Select
End With
End Sub
複製代碼
[attach]12589[/attach]
檔案中 Sheet1 右下資料是保留來驗證用的.
作者:
luke
時間:
2012-9-22 13:19
回復
2#
luhpro
謝謝luhpro 回覆
測試 sheet1表A和D欄任 一儲存格做資料刪除時會出現1004錯誤如下圖示
[attach]12590[/attach]
以上
作者:
GBKEE
時間:
2012-9-22 15:22
回復
3#
luke
Sheet1 的程式碼
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim M As Variant
Application.EnableEvents = False
Select Case Target.Column
Case 1 To 3 'A-C欄儲存格有資料變動
M = Application.Match(Cells(Target.Row, 1), Sheets("sheet2").Columns(1), 0)
'在"sheet2"!A欄 中尋找sheet1!A欄資料
If IsError(M) Then '找不到時 Match函數傳回#N/A 錯誤值
Cells(Target.Row, 2).Resize(, 2) = ""
Else '找到時 Match函數傳回儲存格的列號
Cells(Target.Row, 2).Resize(, 2) = Sheets("sheet2").Cells(M, 2).Resize(, 2).Value
End If
Case 4 To 7 'D-G欄儲存格有資料變動
M = Application.Match(Cells(Target.Row, 4), Sheets("sheet3").Columns(1), 0)
'在"sheet3"!A欄 中尋找sheet1!D欄資料
If IsError(M) Then
Cells(Target.Row, 5).Resize(, 3) = ""
Else
Cells(Target.Row, 5).Resize(, 3) = Sheets("sheet3").Cells(M, 2).Resize(, 3).Value
End If
End Select
Application.EnableEvents = True
End Sub
複製代碼
作者:
Hsieh
時間:
2012-9-22 20:33
回復
3#
luke
一般模組
Public Dic As Object
Sub Auto_Open()
Dim Sht(), A As Range
Set Dic = CreateObject("Scripting.Dictionary")
Sht = Array("Sheet2", "Sheet3")
For Each sh In Sht
With Worksheets(sh)
For Each A In .Range(.[A1], .[A1].End(xlDown))
Select Case sh
Case "Sheet2"
Dic(A.Value) = Array(A.Offset(, 1).Value, A.Offset(, 2).Value)
Case "Sheet3"
Dic(A.Value) = Array(A.Offset(, 1).Value, A.Offset(, 2).Value, A.Offset(, 3).Value)
End Select
Next
End With
Next
End Sub
複製代碼
Sheet1模組
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Count > 1 Then Exit Sub
If IsEmpty(Dic(Target.Value)) Or Target.Count > 1 Then Exit Sub
s = IIf(Target.Column = 1, 2, IIf(Target.Column = 4, 3, 0))
k = UBound(Dic(Target.Value)) + 1
If s <> k Then Exit Sub
Application.EnableEvents = False
Target.Offset(, 1).Resize(, k).Value = Dic(Target.Value)
Application.EnableEvents = True
End Sub
複製代碼
存檔後關閉再重新開啟檔案
歡迎光臨 麻辣家族討論版版 (http://forum.twbts.com/)
