如何解决VBA：使用功能限制像元范围
| 您如何在VBA中编写一个函数，让用户输入一个范围作为参数，并设置该范围的上限/下限（以防他们输入整列）？ 我有一个查看单元格并查看其是否包含词汇表中所列单词的函数（我只允许用户选择作为词汇表术语列表的列（范围）。我目前对范围内的每个单元格使用a循环以遍历该范围，但是即使我先检查Len（cell.value）<> 0，我也不想浪费遍历A列中所有单元格的步骤。 我猜想它是通过select语句完成的，但是现在我确定如何对作为参数传递的范围执行此操作（我现在将其称为cell_range）。 任何帮助将不胜感激！ 添加的信息： 范围的数据类型为字符串类型。这是英语单词（词汇表术语）的列表，我正在编写一个函数，该函数将查看单元格并查看其是否包含词汇表中的任何术语。如果是这样，代码将向右返回词汇表术语和偏移量单元格（翻译后的术语）。 编辑（06.20.11） 由于下面的实验和建议，完成了代码。它需要一个单元格并在其中查找任何词汇表术语。它返回术语列表以及翻译后的术语（词汇表中的第二列）。Function FindTerm(ByVal text As String,ByVal term_list As range) As String
Static glossary As Variant
Dim result As String
Dim i As Long
glossary = range(term_list.Cells(1,1),term_list.Cells(1,2).End(xlDown))
For i = 1 To UBound(glossary)
If InStr(text,glossary(i,1)) <> 0 Then
result = (glossary(i,1) & \" = \") & (glossary(i,2) & vbLf) & result
End If
Next
If result <> vbNullString Then
result = Left$(result,(Len(result) - 1))
End If
FindTerm = result
解决方法
要回答直接的问题，您不能限制将什么作为参数传递，但是可以从传递的范围派生新范围。
也就是说，在范围内循环非常慢。可能有其他方法：
根据Remou的建议，基于查询的方法
将范围复制到变量数组并循环遍历
Dim vDat as variant
vDat = cell_range
cell_range.Find ...
Application.WorksheetFunction.Match
.Index
.VLookup
Function Demo(Glossary As Range,search_cell As Range) As String
Dim aGlossary As Variant
Dim aSearch() As String
Dim i As Long,j As Long
Dim FoundList As New Collection
Dim result As String
Dim r As Range
\' put data into array
aGlossary = Range(Glossary.Cells(1,1),Glossary.Cells(1,1).End(xlDown))
\' assuming words in search cell are space delimited
aSearch = Split(search_cell.Value,\" \")
\'search for each word from search_cell in Glossary
For i = LBound(aSearch) To UBound(aSearch)
For j = LBound(aGlossary,1) To UBound(aGlossary,1)
If aSearch(i) = aGlossary(j,1) Then
\' Add to found list
FoundList.Add aSearch(i),aSearch(i)
Exit For
End If
Next
Next
\'return list as comma seperated list
result = \"\"
For i = 1 To FoundList.Count
result = result & \",\" & FoundList.Item(i)
Next
Demo = Mid(result,2)
End Function
For Each c In Range(\"a:a\").SpecialCells(xlCellTypeConstants)
....
Next c
\'\'Last cell in column A,or first gap
oSheet.Range(\"a1\").End(xlDown).Select
\'\'Or last used cell in sheet - this is not very reliable,but
\'\'may suit if the sheet is not much edited
Set r1 = .Cells.SpecialCells(xlCellTypeLastCell)
Dim r As Range
Dim r1 As Range
Dim r2 As Range
Set r = Application.Selection
Set r1 = r.Cells(1,1)
r1.Select
Set r2 = r1.End(xlDown)
If r2.Row > Sheet1.Cells.SpecialCells(xlCellTypeLastCell).Row Then
MsgBox \"Problem\"
Else
Debug.Print r1.Address
Debug.Print r2.Address
End If
Set r = Range(r1,r2)
Debug.Print r.Address
Dim cn As Object
Dim rs As Object
Dim strFile As String
Dim strCon As String
Dim strSQL As String
Dim s As String
Dim i As Integer,j As Integer
Dim a As String
\'\'It does not matter if the user has selected a whole column,\'\'only the data range will be picked up,nor does it matter if the
\'\'user has selected several cells,except when it comes to the HDR
\'\'I guess you could set HDR = Yes or No accordingly.
\'\'One cell is slightly more difficult,but for one cell you would
\'\'not need anything like this palaver.
a = Replace(Application.Selection.Address,\"$\",\"\")
\'\'This is not the best way to refer to the workbook
\'\'you want,but it is very convenient for notes
\'\'It is probably best to use the name of the workbook.
strFile = ActiveWorkbook.FullName
\'\'Note that if HDR=No,F1,F2 etc are used for column names,\'\'if HDR=Yes,the names in the first row of the range
\'\'can be used.
\'\'This is the Jet 4 connection string,you can get more
\'\'here : http://www.connectionstrings.com/excel
strCon = \"Provider=Microsoft.Jet.OLEDB.4.0;Data Source=\" & strFile _
& \";Extended Properties=\"\"Excel 8.0;HDR=Yes;\"\";\"
\'\'Late binding,so no reference is needed
Set cn = CreateObject(\"ADODB.Connection\")
Set rs = CreateObject(\"ADODB.Recordset\")
cn.Open strCon
\'\'So this is not very interesting:
strSQL = \"SELECT * \" _
& \"FROM [Sheet1$\" & a & \"]\"
\'\'But with a little work,you could end up with:
strSQL = \"SELECT Gloss \" _
& \"FROM [Sheet1$A:A] \" _
& \"WHERE Gloss Like \'%\" & WordToFind & \"%\'\"
\'\'It is case sensitive,so you might prefer:
strSQL = \"SELECT Gloss \" _
& \"FROM [Sheet1$A:A] \" _
& \"WHERE UCase(Gloss) Like \'%\" & UCase(WordToFind) & \"%\'\"
rs.Open strSQL,cn,3,3
\'\'Pick a suitable empty worksheet for the results
\'\'if you want to write out the recordset
Worksheets(\"Sheet3\").Cells(2,1).CopyFromRecordset rs
\'\'Tidy up
rs.Close
Set rs=Nothing
cn.Close
Set cn=Nothing
版权声明：本文内容由互联网用户自发贡献，该文观点与技术仅代表作者本人。本站仅提供信息存储空间服务，不拥有所有权，不承担相关法律责任。如发现本站有涉嫌侵权/违法违规的内容， 请发送邮件至 dio@foxmail.com 举报，一经查实，本站将立刻删除。