返回列表 上一主題 發帖

[發問] 輸入至不同欄位儲存格來個別找出兩個工作表對應值

luke

帖子
140 
主題
37 
精華
0 
積分
193 
點名
0  
作業系統
Windows XP 
軟體版本
Office 2007 
閱讀權限
20 
註冊時間
2012-3-28 
最後登錄
2015-7-5 

2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章
1# 跳轉到 » 倒序看帖
打印
tT
發表於 2012-9-20 20:19 | 只看該作者

[發問] 輸入至不同欄位儲存格來個別找出兩個工作表對應值

各位大大

1.Sheet2表和Sheet3表為資料列各有數千筆資料.
2.Sheet1表A:C欄為Sheet2輸出區,而D:G欄為Sheet3輸出區.
3.自A7和D7儲存格往下開始做個別資料輸入,例如:
A7儲存格

TEST25.rar (32.43 KB)

收藏 分享

luhpro

帖子
835 
主題
6 
精華
0 
積分
915 
點名
0  
作業系統
Win 10,7 
軟體版本
2019,2013,2003 
閱讀權限
50 
性別
男 
註冊時間
2010-5-3 
最後登錄
2025-7-5 
2#
發表於 2012-9-22 09:36 | 只看該作者
各位大大

1.Sheet2表和Sheet3表為資料列各有數千筆資料.
2.Sheet1表A:C欄為Sheet2輸出區,而D:G欄為Shee ...
luke 發表於 2012-9-20 20:19

Module1
  1. Public v2, v3
複製代碼
ThisWorkBook
  1. Private Sub Workbook_Open()
  2.   Dim rTar As Range
  3.   
  4.   Set v2 = CreateObject("Scripting.Dictionary")
  5.   Set v3 = CreateObject("Scripting.Dictionary")
  6.   
  7.   With Sheets("sheet2")
  8.     For Each rTar In .Range(.[A2], .[A2].End(xlDown))
  9.       v2(rTar & "") = rTar.Row
  10.     Next rTar
  11.   End With
  12.   
  13.   With Sheets("sheet3")
  14.     For Each rTar In .Range(.[A2], .[A2].End(xlDown))
  15.       v3(rTar & "") = rTar.Row
  16.     Next rTar
  17.   End With
  18. End Sub
複製代碼
Sheet1
  1. Private Sub Worksheet_Change(ByVal Target As Range)
  2.   Dim iI%
  3.   Dim rTar As Range
  4.   
  5.   Set rTar = Target
  6.   With rTar
  7.     Select Case .Column
  8.    
  9.       Case 1 ' 區分
  10.         With .Parent
  11.           For iI = 2 To 3
  12.             .Cells(rTar.Row, iI) = Sheets("sheet2").Cells(v2(rTar.Text), iI)
  13.           Next iI
  14.         End With
  15.    
  16.       Case 4 ' 票號
  17.         With .Parent
  18.           For iI = 2 To 4
  19.             .Cells(rTar.Row, iI + 3) = Sheets("sheet3").Cells(v3(rTar.Text), iI)
  20.           Next iI
  21.         End With
  22.    
  23.     End Select
  24.   End With
  25. End Sub
複製代碼
TEST25-ans.zip (38.42 KB)
檔案中 Sheet1 右下資料是保留來驗證用的.

TOP

luke

帖子
140 
主題
37 
精華
0 
積分
193 
點名
0  
作業系統
Windows XP 
軟體版本
Office 2007 
閱讀權限
20 
註冊時間
2012-3-28 
最後登錄
2015-7-5 

2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章
3#
發表於 2012-9-22 13:19 | 只看該作者
回復 2# luhpro


    謝謝luhpro 回覆

    測試 sheet1表A和D欄任 一儲存格做資料刪除時會出現1004錯誤如下圖示
    1004.jpg
   
    以上

TOP

GBKEE

帖子
5923 
主題
13 
精華
1 
積分
5986 
點名
0  
作業系統
win10 
軟體版本
Office 2010 
閱讀權限
150 
性別
男 
來自
台灣基隆 
註冊時間
2010-5-1 
最後登錄
2022-1-23 

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
4#
發表於 2012-9-22 15:22 | 只看該作者
回復 3# luke
Sheet1 的程式碼
  1. Option Explicit
  2. Private Sub Worksheet_Change(ByVal Target As Range)
  3.     Dim M As Variant
  4.     Application.EnableEvents = False
  5.     Select Case Target.Column
  6.         Case 1 To 3                             'A-C欄儲存格有資料變動
  7.             M = Application.Match(Cells(Target.Row, 1), Sheets("sheet2").Columns(1), 0)
  8.             '在"sheet2"!A欄 中尋找sheet1!A欄資料
  9.             If IsError(M) Then                  '找不到時 Match函數傳回#N/A 錯誤值
  10.                 Cells(Target.Row, 2).Resize(, 2) = ""
  11.             Else                                '找到時 Match函數傳回儲存格的列號
  12.                 Cells(Target.Row, 2).Resize(, 2) = Sheets("sheet2").Cells(M, 2).Resize(, 2).Value
  13.             End If
  14.         Case 4 To 7                              'D-G欄儲存格有資料變動
  15.             M = Application.Match(Cells(Target.Row, 4), Sheets("sheet3").Columns(1), 0)
  16.             '在"sheet3"!A欄 中尋找sheet1!D欄資料
  17.             If IsError(M) Then
  18.                 Cells(Target.Row, 5).Resize(, 3) = ""
  19.             Else
  20.                 Cells(Target.Row, 5).Resize(, 3) = Sheets("sheet3").Cells(M, 2).Resize(, 3).Value
  21.             End If
  22.     End Select
  23.     Application.EnableEvents = True
  24. End Sub
複製代碼

TOP

Hsieh

帖子
4901 
主題
44 
精華
24 
積分
4916 
點名
142  
作業系統
Windows 7 
軟體版本
Office 20xx 
閱讀權限
150 
性別
男 
來自
台北 
註冊時間
2010-4-30 
最後登錄
2026-7-16 

2025年全勤獎章2024年全勤獎章2023年全勤獎章2022虎年全勤獎章2021牛年全勤獎章2020鼠年全勤獎章2019 豬年全勤獎章2018 狗年全勤獎章2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱心公益勳章2011兔年全勤獎章
5#
發表於 2012-9-22 20:33 | 只看該作者
回復 3# luke

一般模組
  1. Public Dic As Object
  2. Sub Auto_Open()
  3. Dim Sht(), A As Range
  4. Set Dic = CreateObject("Scripting.Dictionary")
  5. Sht = Array("Sheet2", "Sheet3")
  6. For Each sh In Sht
  7.    With Worksheets(sh)
  8.       For Each A In .Range(.[A1], .[A1].End(xlDown))
  9.          Select Case sh
  10.          Case "Sheet2"
  11.          Dic(A.Value) = Array(A.Offset(, 1).Value, A.Offset(, 2).Value)
  12.          Case "Sheet3"
  13.          Dic(A.Value) = Array(A.Offset(, 1).Value, A.Offset(, 2).Value, A.Offset(, 3).Value)
  14.          End Select
  15.         Next
  16.     End With
  17. Next
  18. End Sub
複製代碼
Sheet1模組
  1. Private Sub Worksheet_Change(ByVal Target As Range)
  2. If Target.Count > 1 Then Exit Sub
  3. If IsEmpty(Dic(Target.Value)) Or Target.Count > 1 Then Exit Sub
  4. s = IIf(Target.Column = 1, 2, IIf(Target.Column = 4, 3, 0))
  5. k = UBound(Dic(Target.Value)) + 1
  6. If s <> k Then Exit Sub
  7. Application.EnableEvents = False
  8. Target.Offset(, 1).Resize(, k).Value = Dic(Target.Value)
  9. Application.EnableEvents = True
  10. End Sub
複製代碼
存檔後關閉再重新開啟檔案
學海無涯_不恥下問

TOP

        靜思自在 : 世上有兩件事不能等：一、孝順 二、行善。
返回列表 上一主題