Excel VBA：将范围对象转换为数组
背景：您将在下面查看的代码是用于访客列表。 在执行时，它会要求提供名字列表，姓氏列表，电子邮件地址列表，分数值和事件名称。 然后，程序在第一个空列的第一行input事件名称。 然后，if循环根据电子表格中的现有列表检查提供给它的每个名称。 如果find名字和姓氏，则将该点值添加到该行的新事件列中。 如果找不到该名称，则会将姓和名添加到底部的新行，电子邮件地址，两个总计公式，以及新列中的点值。 这是预期的情况。
我首先用下面的代码获得一个名字列表
Dim fNameStringRange As Range fNameStringRange = Application.InputBox("Select the list of first names.", "Obtain Range Object", Type:=8) 然后我使用用户函数RangeToArray转换它。 代码如下：
Function RangeToArray(inputRange As Range) As Variant Dim inputArray As Variant inputArray = inputRange.Value 'operations on inputArray '...' RangeToArray = inputArray End Function Dim fNameString As Variant fNameString = RangeToArray(fNameStringRange)
不过由于某些原因，我的代码并没有像这样处理。 当我有它填写这些名字到我的工作表，它不填写任何东西。 之前，这可以很好的使用type:=2的InputBox 。 任何援助表示赞赏。 我的完整的VBA脚本如下：
Sub addEvent() On Error Resume Next Dim fNameStringRange As Range Dim lNameStringRange As Range Dim sEmailStringRange As Range Dim fNameString As Variant Dim lNameString As Variant Dim sEmailString As Variant Dim nPointVal As Integer Dim sEventName As String Dim n As Integer, r As Long, c As Range, d As Range, e As Range, p As Range, sE As Range Dim fName As Range, lName As Range, sEmail As Range, z As Range Dim lEvent As Integer Set fName = ActiveSheet.Range("FirstName") Set lName = ActiveSheet.Range("LastName") Set sEmail = ActiveSheet.Range("eMailAddr") fNameStringRange = Application.InputBox("Select the list of first names.", "Obtain Range Object", Type:=8) lNameStringRange = Application.InputBox("Select the list of last names.", "Obtain Range Object", Type:=8) sEmailStringRange = Application.InputBox("Select the list of email addresses.", "Obtain Range Object", Type:=8) fNameString = RangeToArray(fNameStringRange) lNameString = RangeToArray(lNameStringRange) sEmailString = RangeToArray(sEmailStringRange) nPointVal = InputBox("Please enter a point value for this event") sEventName = InputBox("Please enter the name of the event.") lEvent = NextEmptyColumn(Range("A1")) Set sE = Range("A1").Offset(0, lEvent) sE.Value = sEventName ' sEventPos = sE.Offset(0, lEvent) If fNameString <> False And lNameString <> False Then For i = LBound(fNameString) To UBound(fNameString) fNameString(i) = Trim(fNameString(i)) ' Trim off leading and trailing whitespace. lNameString(i) = Trim(lNameString(i)) ' Trim off leading and trailing whitespace. Set c = fName.Find(fNameString(i), LookIn:=xlValues, LookAt:=xlWhole) Set d = lName.Find(lNameString(i), LookIn:=xlValues, LookAt:=xlWhole) If Not c Is Nothing And Not d Is Nothing Then Set p = c.Offset(0, lEvent) p.Value = nPointVal ElseIf c Is Nothing And d Is Nothing Or c Is Nothing And Not d Is Nothing _ Or Not c Is Nothing And d Is Nothing Then Set c = fName.End(xlDown).Offset(1, 0) c.Value = fNameString(i) Set d = lName.End(xlDown).Offset(1, 0) d.Value = lNameString(i) Set e = sEmail.End(xlDown).Offset(1, 0) e.Value = sEmailString(i) Set p = fName.End(xlDown).Offset(0, lEvent) p.Value = nPointVal Dim s As Range ' Our summation range Set s = Range(c.Offset(0, 4), c.Offset(0, 4)) Dim rD As Integer rD = Application.WorksheetFunction.RoundDown((s.Address / 250), 0) c.Offset(0, 3).Formula = "=((" & s.Address & "/250)-ROUNDDOWN((" & s.Address & "/250),0))*250" Set s = Range(c.Offset(0, 5), c.Offset(0, 42)) c.Offset(0, 4).Formula = "=SUM(" & s.Address & ")" c.Offset(0, 5).Value = 0 End If Next End If End Sub
这是根据要求进行的一些修改。 看起来最大的问题不是数组，而是你不清楚c和d，这意味着testing没有转移到其他条件。 我不能确定这个原因，我必须玩几件事情，做出假设和数据。 但是我希望这能让你走上正轨。
Sub addEvent() On Error Resume Next Dim fNameString As Variant Dim lNameString As Variant Dim sEmailString As Variant Dim nPointVal As Integer Dim sEventName As String Dim n As Integer, r As Long, c As Range, d As Range, e As Range, p As Range, sE As Range Dim fName As Range, lName As Range, sEmail As Range, z As Range Dim lEvent As Integer Set fName = ActiveSheet.Range("FirstName") Set lName = ActiveSheet.Range("LastName") Set sEmail = ActiveSheet.Range("eMailAddr") fNameString = Application.InputBox("Select the list of first names.", "Obtain Range Object", Type:=8) lNameString = Application.InputBox("Select the list of last names.", "Obtain Range Object", Type:=8) sEmailString = Application.InputBox("Select the list of email addresses.", "Obtain Range Object", Type:=8) nPointVal = InputBox("Please enter a point value for this event") sEventName = InputBox("Please enter the name of the event.") lEvent = NextEmptyColumn(Range("A1")) Set sE = Range("A1").Offset(0, lEvent) sE.Value = sEventName ' sEventPos = sE.Offset(0, lEvent) If fNameString <> False And lNameString <> False Then For i = LBound(fNameString) To UBound(fNameString) 'clear the range variables to ensure the tests are correctly applied 'was previously retaining old value and not progressing to second condition Set c = Nothing: Set d = Nothing: Set p = Nothing fNameString(i, 1) = Trim(fNameString(i, 1)) ' Trim off leading and trailing whitespace. lNameString(1, 1) = Trim(lNameString(i, 1)) ' Trim off leading and trailing whitespace. Set c = fName.Find(fNameString(i, 1), LookIn:=xlValues, LookAt:=xlWhole) Set d = lName.Find(lNameString(i, 1), LookIn:=xlValues, LookAt:=xlWhole) If Not c Is Nothing And Not d Is Nothing Then Set p = c.Offset(0, lEvent) p.Value = nPointVal ElseIf c Is Nothing Or d Is Nothing Then Set c = fName.End(xlDown).Offset(1, 0) c.Value = fNameString(i, 1) Set d = lName.End(xlDown).Offset(1, 0) d.Value = lNameString(i, 1) Set e = sEmail.End(xlDown).Offset(1, 0) e.Value = sEmailString(i, 1) Set p = fName.End(xlDown).Offset(0, lEvent) p.Value = nPointVal Dim s As Range ' Our summation range Set s = Range(c.Offset(0, 4), c.Offset(0, 4)) Dim rD As Integer rD = Application.WorksheetFunction.RoundDown((s.Address / 250), 0) c.Offset(0, 3).Formula = "=((" & s.Address & "/250)-ROUNDDOWN((" & s.Address & "/250),0))*250" Set s = Range(c.Offset(0, 5), c.Offset(0, 42)) c.Offset(0, 4).Formula = "=SUM(" & s.Address & ")" c.Offset(0, 5).Value = 0 End If Next End If End Sub