[發問] 如何從兩欄中尋找出指定值

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

2017 雞年全勤獎章 2016猴年全勤獎章 2015羊年全勤獎章 2014馬年全勤獎章 2013蛇年全勤獎章 2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章 2011兔年全勤獎章

11^#

發表於 2013-5-29 09:06 | 只看該作者

回復 10# luke
執行 [寫入Work]前須先執行 [Link] 確定工作表的超連結.

Sub Link()
Dim D As Object, R As Integer, C As Range, A As Range, Ky As Variant
Set D = CreateObject("Scripting.Dictionary")
With Sheets("sheet1")
Set A = .[A:A].Find([J1], lookat:=xlWhole)
If [J1] = "" Then Exit Sub
For Each C In .Range(A, .[A65536].End(xlUp))
If C & C.Offset(, 1) Like .[I3] & .[J3] Then
D(C.Value & D.Count) = C.Resize(, 2).Address(0, 0)
End If
Next
[L:N].Clear
If D.Count = 0 Then MsgBox "無符合資料": Exit Sub
For Each Ky In D.keys
R = R + 1
.Cells(R, "L") = .Range(D(Ky)).Cells(1, 1)
.Cells(R, "M") = .Range(D(Ky)).Cells(1, 2)
.Hyperlinks.Add Anchor:=.Cells(R, "N"), Address:="", SubAddress:=D(Ky)
Next
End With
Range("J3").Select
End Sub
Sub 寫入Work()
Dim Rng(1 To 3) As Range, E As Variant, R As Range
Set Rng(1) = Sheets("Work").UsedRange.Range("a:a")
For Each E In Sheets("Sheet1").Hyperlinks '物件集合:工作表的超連結。
Set Rng(2) = Sheets("Sheet1").Range(E.SubAddress) '制定: 超連結的儲存格
For Each R In Rng(1)
If Rng(2).Cells(1) & Rng(2).Cells(1, 2) = R & R.Cells(1, 2) Then '與超連結儲存格的內容相同
Set Rng(3) = R.CurrentRegion '範圍只有AB兩欄
'CurrentRegion 屬性傳回 Range 物件，該物件代表目前的區域。目前區域是指以任意空白列及空白欄的組合為邊界的範圍。唯讀。
Rng(2).CurrentRegion.Copy '複製:超連結儲存格的連續範圍
Rng(3)(1).Insert Shift:=xlDown '插入貼上:超連結儲存格的連續範圍
'Rng(3)(1) => Rng(3).Cells(1, 1) '範圍的第一個楚墫格
Set Rng(3) = Rng(3).Range("A1:C" & Rng(3).Rows.Count) '多增加一欄保持資料的完整性 (C欄也要刪除)
Rng(3).Delete Shift:=xlUp '刪除: 下方儲存格上移
Exit For
End If
Next
Next
Set Rng(1) = Sheets("Sheet1").[A:A].Find("END", lookat:=xlWhole) '[SHEET1]A欄中尋找: "END"
Set Rng(1) = Sheets("Sheet1").Range("A1:C" & Rng(1).Row) '制定範圍: A欄到C欄 "END"的列號
Rng(1).Copy Sheets("Work").Cells(Sheets("Work").Rows.Count, 1).End(xlUp)
MsgBox "完成"
End Sub

複製代碼

感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限, 一天1元的贊助,人人有能力.

luke

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

2014馬年全勤獎章 2013蛇年全勤獎章 2012龍年全勤獎章

10^#

發表於 2013-5-29 06:01 | 只看該作者

本帖最後由 luke 於 2013-5-29 06:05 編輯

回復 9# GBKEE

回覆超版

1.[Sheet1表]插入資料至[WORK表]有4個資料區
A1:C10
A13:C16
A18:C21
A23:C27
2.執行「寫入WORK」按鍵時因[WORK表]有部份資料列與[Sheet1表]重覆就會產生錯誤, 若[WORK表]改copy方式, 直接複製[Sheet1表]的4個資料區至[WORK表]

If D.EXISTS(A.Cells(1, 1) & A.Cells(1, 2)) Then
D(A.Cells(1, 1) & A.Cells(1, 2)).Copy
With A.Resize(1, D(A.Cells(1, 1) & A.Cells(1, 2)).Columns.Count)
.Insert Shift:=xlDown
End With
End If

應如何修改上述VBA語法?

以上

TEST27D.rar (37.33 KB)

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

2017 雞年全勤獎章 2016猴年全勤獎章 2015羊年全勤獎章 2014馬年全勤獎章 2013蛇年全勤獎章 2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章 2011兔年全勤獎章

9^#

發表於 2013-5-5 21:11 | 只看該作者

本帖最後由 GBKEE 於 2013-5-5 21:12 編輯

回復 8# luke
不好意思,看了兩天,你說的很詳細但還是看不懂
可以附上檔案的4個工作表內容是
1 [SHEET1 A]工作表是  文字檔A型
2 [SHEET1 B]工作表是  文字檔B型
3 [A WORK]工作表是 :  文字檔A型貼上[A WORK]工作表後執行複製插入的範例
4 [B WORK]工作表是 : 文字檔B型貼上[A WORK]工作表後執行刪除插入的範例

感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限, 一天1元的贊助,人人有能力.

luke

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

2014馬年全勤獎章 2013蛇年全勤獎章 2012龍年全勤獎章

8^#

發表於 2013-5-3 23:12 | 只看該作者

回復 7# GBKEE

回復超版

以下是說明, 請參考附件{WORK結果}表所示結果

說明: 從[Sheet1表]A:C欄匯入文字檔可分為A型和B型.
[A型]
1.當匯入A型文字檔會有「END」(稱第1個資料區)及/或數量不等的資料區(稱第2個資料區、第3個資料區、第4資料區…餘此類推)如從Sheet1表A:C欄所示, 其中第1個資料區帶有空白資料列, 而第2個資料區以後, 每個資料區有數量不等資料列(但不含空白資料列). [Sheet1表]G:I欄是由D3儲存格(E3用Y*)為做查詢並先跳過「END」再行找出篩選結果. 例如:D3輸入「EEE」時會找出符合的Y01, Y04和Y02共3筆資料, 然後顯示結果(如G1:I3)於Sheet1表G:I欄(I欄有超連結功能).

2.[WORK表]是資料寫入工作表,其最後1列有1個「END」檔尾(上1列為空白資料列), [Sheet1表]的第1個資料區是以此「END」做複製目的. 當選取[Sheet1表]的第1個資料區後再複製至[WORK表]並覆蓋「END」貼上. 若A型文字檔還有其他的資料區就要做相互尋找與插入(複製貼上)功能; 並利用上述篩選結果, 由[WORK表] G:H欄開始先找出G1和H1內容如G1=「EEE」和H1=「Y01」(本例如第1點說明)進行[Sheet1表]的第2個資料區(如A13:C14)做複製, 然後切換至[WORK表]去找到符合[Sheet1表] G1=「EEE」和H1=「Y01」的位址, 將[Sheet1表]的第2個資料區插入此位址(如[WORK表]所示結果).

同理:
繼續做下個G2=「EEE」和H2=「Y04」並將[Sheet1表] 的第3個資料區(如A16:C17)做複製並插入至[WORK表]符合[Sheet1表] G2=「EEE」和H2=「Y04」的位址. 然後繼續做下個G3=「EEE」和H3=「Y02」並將[Sheet1表] 的第4個資料區(如A19:C21)做複製並插入至[WORK表]符合[Sheet1表] G3=「EEE」和H3=「Y02」的位址…餘此類推

[B型]
當匯入B型文字檔至[Sheet1表]A:C欄(範例顯示於L: M欄)就會有「MMM」做檔尾, 但不會有「END」,其資料是以[Sheet1表]D3和E3來做[WORK表]刪除功能. 若D3輸入「EEE」和E3輸入「Y15」,就會進行[WORK表]符合D3:「EEE」和E3:「Y15」查詢, 找到此筆資料(僅1筆)的地址後,往上選取[WORK表]A:C欄區塊資料列並做該區塊資料列刪除工作, 然後將B型文字檔的[Sheet1表]資料全部選取(如L3:N8)並插入貼至[WORK表]該處(如C34)即完成.

應如何修改VBA達到這樣的結果?

TEST27B.rar (104.77 KB)

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

2017 雞年全勤獎章 2016猴年全勤獎章 2015羊年全勤獎章 2014馬年全勤獎章 2013蛇年全勤獎章 2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章 2011兔年全勤獎章

7^#

發表於 2013-5-2 15:34 | 只看該作者

回復 6# luke
果想跳過第1個有「END」資料區
只有1個「END」資料區嗎??????
請將問題完整的提出來!!!

感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限, 一天1元的贊助,人人有能力.

luke

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

2014馬年全勤獎章 2013蛇年全勤獎章 2012龍年全勤獎章

6^#

發表於 2013-5-2 10:52 | 只看該作者

回復 7# GBKEE

謝謝超版答覆

若sheet1表D3儲存格內容固定不變(不考慮E3儲存格), 如果想跳過第1個有「END」資料區,
然後由第2個資料區去查詢A:B欄中, 去做進階篩選(如圖片所示)出符合D3儲存格的全部資料.

例如:D3輸入「EEE」,從第2個資料區A欄
可找出第45列、第48列和第51列共有3列有「EEE」相同值如下:

第45列 EEE→Y01
第48列 EEE→Y04
第51列 EEE→Y02

如何修改VBA將A:B欄中的這些符合篩選資料複製至G:H欄?

TEST27B.rar (28.83 KB)

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

2017 雞年全勤獎章 2016猴年全勤獎章 2015羊年全勤獎章 2014馬年全勤獎章 2013蛇年全勤獎章 2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章 2011兔年全勤獎章

5^#

發表於 2013-5-2 07:41 | 只看該作者

回復 5# luke

Private Sub Auto_open() 'Module1 於檔案開啟時自動執行的程式,要定義:"END"區塊位置
'Names.Add 活頁簿中定義新名稱
With sheet1.Range("A:A")
If Not .Find("END", lookat:=xlWhole) Is Nothing Then
.Replace "END", "=EX", xlWhole
'將"END"替代為公式,因為無效的公式,儲存格傳回錯誤值
With .SpecialCells(xlCellTypeFormulas, xlErrors)
Names.Add "資料區", RefersTo:=.Parent.Range(.Address)
.Value = "END" '儲存格傳回錯誤值:回復原字串
End With
Names.Add "按鈕次數", 1 '按鈕1 第一個資料區
Else
Names.Add "按鈕次數", 0 '按鈕1
End If
End With
End Sub
Sub Ex()
Dim i As Integer, W As String, Rng As Range
If [按鈕次數] = 0 Then
MsgBox "資料區沒有 END區塊 "
Exit Sub
End If
With ActiveSheet
W = Application.Phonetic(.[D3:E3]) '結合兩字串
'i = [資料區].Areas([按鈕次數]).Row '第 i 個"END"資料區的列號
For i = [資料區].Areas([按鈕次數]).Row To [資料區].Areas([資料區].Areas.Count).Row
If W = Application.Phonetic(.Range("A:B").Rows(i)) Then
Names.Add "按鈕次數", [按鈕次數] + 1 '
Set Rng = .Range("A:B").Rows(i)
Exit For '找到第一個離開迴圈
End If
Next
If Rng Is Nothing Then
MsgBox "查無 " & .[D3] & .[E3] & "資料"
Else
Rng.Select
MsgBox "找到 " & Rng.Cells(1, 1).Address(0, 0)
End If
End With
If [資料區].Areas.Count = [按鈕次數] Then Names.Add "按鈕次數", 1 '[按鈕次數] 回到第一次
End Sub

複製代碼

感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限, 一天1元的贊助,人人有能力.

luke

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

2014馬年全勤獎章 2013蛇年全勤獎章 2012龍年全勤獎章

4^#

發表於 2013-5-1 18:28 | 只看該作者

回復 3# GBKEE

謝謝超版答覆

若sheet1表的A:B欄資料區是由兩個(或多個)文字檔匯入,  並有「END」檔尾區隔
如果想跳過第1個有「END」結尾, 來進行sheet1表D3和E3的查詢, 即D3輸入「DD」
和E3輸入「Z1」  會先跳過第1個有「END」, 然後由下找到位於第2個資料區的
【儲存格A45】而不是【儲存格A19】.

   同理: sheet1表D3輸入「BB」和E3輸入「X001」是否能往下跳
至第2個資料區的【儲存格A56】而不是【儲存格A32】

以上是否可行?
應如何修改VBA?

TEST27A.rar (30.21 KB)

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

2017 雞年全勤獎章 2016猴年全勤獎章 2015羊年全勤獎章 2014馬年全勤獎章 2013蛇年全勤獎章 2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章 2011兔年全勤獎章

3^#

發表於 2013-4-28 15:46 | 只看該作者

回復 1# luke

Option Explicit
Sub Ex()
Dim R As Range, W As String, Rng As Range
With ActiveSheet
W = Application.Phonetic(.[D3:E3]) '結合兩字串
For Each R In .Range("A:B").SpecialCells(xlCellTypeConstants).Rows '有資料的儲存格
If W = Application.Phonetic(R) Then
If Rng Is Nothing Then
Set Rng = R
Else
Set Rng = Union(Rng, R)
End If
End If
Next
If Rng Is Nothing Then
MsgBox "查無 " & .[D3] & .[E3] & "資料"
Else
Rng.Select
MsgBox "共 " & Rng.Cells.Count / 2 & "筆資料"
End If
End With
End SubEnd Sub

複製代碼

感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限, 一天1元的贊助,人人有能力.