麻辣家族討論版版 - Powered by Discuz! Board

Sub Test()
Dim Txt1 As String, Txt2 As String
Txt1 = [D3]
Txt2 = [E3]
[D3] = IIf(Left(Txt1, 1) = ";", Mid(Txt1, 2, Len(Txt1) - 1), Txt1)
[E3] = IIf(Left(Txt2, 1) = ";", Mid(Txt2, 2, Len(Txt2) - 1), Txt2)
Cells.Find(What:=[D3], LookIn:=xlValues).Activate
i = 1
Do
Cells.FindNext(After:=ActiveCell).Activate
If Cells(ActiveCell.Row, 1).Value = [D3] And Cells(ActiveCell.Row, 2).Value = [E3] Then
Exit Do
ElseIf i > 4000 Then
MsgBox "查無 " + [D3] + [E3] & "資料"
Exit Do
End If
i = i + 1
Loop
End Sub

複製代碼

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

複製代碼

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

複製代碼

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

複製代碼