select具有特定标题的列范围
我有一个macros代码，但它运行在特定的列上，只有500的范围。 我希望它应该dynamicselect标题栏“产品”存在。 如果可能的话，我们可以增加“产品”栏中所有数据的限制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 我将首先将链接构build部分提取到一个单独的子例程中。
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
然后，我会添加一个函数来find列…
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来提醒自己如何获得工作表中最后使用的单元格（请参阅从Range VBA查找最后一个单元格 ）。
下面的代码将find哪个列有标题PRODUCTS ，然后find该列中的最后一行，并将其存储在variableslrProdCol 。
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
所以replace下面的代码
myCheck = MsgBox("Do you have Patent Numbers in Column - B ?", vbYesNo) If myCheck = vbNo Then Exit Sub endrw = Range("B500").End(xlUp).Row
用上面的线。 希望有所帮助