選擇具有特定標題的列範圍

Question

我有一個宏代碼，但它運行在特定的列上，範圍僅爲500。我希望它應該動態選擇標題欄'PRODUCTS'存在。如果可能的話，我們可以增加「產品」欄中所有數據的限制500。

Sub Pats() 

myCheck = MsgBox("Do you have Patent Numbers in Column - B ?", vbYesNo) 
    If myCheck = vbNo Then Exit Sub 

endrw = Range("B500").End(xlUp).Row 

Application.ScreenUpdating = False 

For i = 2 To endrw 
PatNum = Cells(i, 2).Value 
If Left(Cells(i, 2), 2) = "US" Then 
link = "http://www.google.com/patents/" & PatNum 
Cells(i, 2).Select 
ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:="http://www.google.com/patents/" & PatNum, ScreenTip:="Click to View", TextToDisplay:=PatNum 
With Selection.Font 
     .Name = "Arial" 
     .Size = 10 
End With 

ElseIf Left(Cells(i, 2), 2) = "EP" Then 
link = "http://www.google.com/patents/" & PatNum 
Cells(i, 2).Select 
ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:="http://www.google.com/patents/" & PatNum, ScreenTip:="Click to View", TextToDisplay:=PatNum 
With Selection.Font 
     .Name = "Arial" 
     .Size = 10 
End With 

End If 
Next i 
End Sub 

Answer 1

我會先提取鏈接建設的一部分到一個單獨的子程序...

Sub AddLink(c As Range) 
    Dim link As String 
    Dim patNum As String 
    Dim test As String 
    patNum = c.Value 
    test = UCase(Left(patNum, 2)) 
    If test = "US" Or test = "EP" Then 
     link = "http://www.google.com/patents/" & patNum 
    Else 
     link = "http://www.www.hyperlink.com/" & patNum 
    End If 
    c.Hyperlinks.Add Anchor:=c, Address:=link, ScreenTip:="Click to View", TextToDisplay:=patNum 
    With c.Font 
     .Name = "Arial" 
     .Size = 10 
    End With 
End Sub 

然後，我會添加一個功能，找到列...

Function FindColumn(searchFor As String) As Integer 
    Dim i As Integer 
    'Search row 1 for searchFor 
    FindColumn = 0 
    For i = 1 To ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell).Column 
     If ActiveSheet.Cells(1, i).Value = searchFor Then 
      FindColumn = i 
      Exit For 
     End If 
    Next i 
End Function 

最後我會把它放在一起...

Sub Pats() 
    Dim col As Integer 
    Dim i As Integer 
    col = FindColumn("PRODUCTS") 
    If col = 0 Then Exit Sub 
    For i = 2 To ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell).Row 
     AddLink ActiveSheet.Cells(i, col) 
    Next i 
End Sub 

我承認我必須使用SO來提醒自己如何得到t他最後在工作表上使用了單元格（請參閱Find Last cell from Range VBA）。

Answer 2

下面的代碼會發現哪一列具有標題PRODUCTS然後找到該列的最後一行並將其存儲在變量lrProdCol。

Sub FindProductLR() 
    Dim col As Range 
    Dim endrw As Long 

    Set col = Rows(1).Find("PRODUCTS") 
    If Not col Is Nothing Then 
     endrw = Cells(Rows.count, col.Column).End(xlUp).Row 
    Else 
     MsgBox "The 'PRODUCTS' Column was not found in row 1" 
    End If 
End Sub 

所以替換的代碼

myCheck = MsgBox("Do you have Patent Numbers in Column - B ?", vbYesNo) 
    If myCheck = vbNo Then Exit Sub 

endrw = Range("B500").End(xlUp).Row 

以下比特通過上面的行。希望幫助