CODEWITHSUNDEEP
vbaexcel
Jonathan Rauscher
Jonathan Rauscher

Reputation: 157

Excel VBA: Converting Range Object to Array

Background: The code you will view below is for a guest list. When executed, it will ask for a list of first names, a list of last names, a list of email addresses, a point value, and an event name. Then, the program enters the event name on the first row of the first empty column. Then, the if loop checks each name that it was supplied to as a list against an existing list in a spreadsheet. If the first and last name are found, it adds the point value to the new event column for that row. If the name is not found, it adds the first and last name to a new row at the bottom, the email address, two formulas for totals, and then the point value within the new column. This is the intended scenario.

I first obtain a list of names with the following code

Dim fNameStringRange As Range

fNameStringRange = Application.InputBox("Select the list of first names.", "Obtain Range Object", Type:=8)

Then I convert it using the user function RangeToArray. The code for this is below:

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)

For some reason however, my code does not process this through as such. When I have it fill these names into my sheet, it doesn't fill in anything. Before, this would work just fine using a InputBox of type:=2. Any assistance is appreciated. My full VBA script is below: 

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

Upvotes: 0

Views: 1451

Answers (1)

Captain Grumpy
Captain Grumpy

Reputation: 520

Here is a few modifications as requested. Looks like the biggest issue was not so much the array but you weren't clear c and d which meant the test was not moving to the else condition. I cant be sure of that cause I had to play with a few things, make assumptions and make data. But I hope this gets you on the right track now.

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

Upvotes: 1

Related Questions