Export array values to Excel

[gmaxey]

Hi,

I'm trying to write the values of a single dimension array to a new Excel worksheet:

Sub Problem()
Dim arrTest() As String
arrTest = Split("A|B|C|D", "|")
WriteToExcel arrTest
End Sub
Sub WriteToExcel(ByVal arrPassed)
Dim o As Object
  Set o = CreateObject("excel.application")
  o.Visible = True
  o.Workbooks.Add
  o.sheets("sheet1").Range("A1:A" & UBound(arrPassed) + 1).Value = arrPassed
End Sub

The result I get is "A" in each cell. How do I revise this code so that "A" is in Cell A1, "B" is in Cell A2, etc.

Is there a better way to write an array to Excel? Thanks.

[JKwan]

try this, don't know if it is the best way:

Sub Problem()
    Dim arrTest() As String
    arrTest = Split("A|B|C|D", "|")
    WriteToExcel arrTest
End Sub
Sub WriteToExcel(ByVal arrPassed)
    Dim o As Object
    Dim Destination As Range
    
    Set o = CreateObject("excel.application")
    o.Visible = True
    o.Workbooks.Add
    Set Destination = o.Sheets("sheet1").Range("A1")
    Set Destination = Destination.Resize(UBound(arrPassed) + 1, 1)
    Destination.Value = Application.Transpose(arrPassed)
    
    Set Destination = Nothing
    Set o = Nothing
End Sub

[Kenneth Hobs]

Sub WriteToExcel(ByVal arrPassed)
  Dim o As Object
  Set o = CreateObject("excel.application")
  With o
    .Visible = True
    .Workbooks.Add
    .sheets("sheet1").Range("A1").Resize(UBound(arrPassed) + 1).Value = .Transpose(arrPassed)
  End With
End Sub

[gmaxey]

JKwan, Thanks for your time and post. Kenneth's was less code and works.

[gmaxey]

Kenneth,

Thanks! That works great. Here I am with my hand out again though. I suppose my initial question was too simplistic. What if I have a multi-demensional array and need to write each array element to a row:

Sub ProblemNew()
Dim arrTest(3, 1)
  arrTest(0, 0) = "A"
  arrTest(0, 1) = "Apple"
  arrTest(1, 0) = "B"
  arrTest(1, 1) = "Blueberry"
  arrTest(2, 0) = "C"
  arrTest(2, 1) = "Cherry"
  arrTest(3, 0) = "DA"
  arrTest(3, 1) = "Dill pickle"
  WriteToExcel arrTest
End Sub
Sub WriteToExcel(ByVal arrPassed)
Dim o As Object
  Set o = CreateObject("excel.application")
  With o
    .Visible = True
    .Workbooks.Add
    .sheets("sheet1").Range("A1").Resize(UBound(arrPassed) + 1).Value = .Transpose(arrPassed)
  End With
End Sub

Thanks again.

[JKwan]

try this, once again may not be the best

Sub ProblemNew()
    Dim arrTest(3, 1)
    arrTest(0, 0) = "A"
    arrTest(0, 1) = "Apple"
    arrTest(1, 0) = "B"
    arrTest(1, 1) = "Blueberry"
    arrTest(2, 0) = "C"
    arrTest(2, 1) = "Cherry"
    arrTest(3, 0) = "DA"
    arrTest(3, 1) = "Dill pickle"
    WriteToExcel arrTest
End Sub
Sub WriteToExcel(ByVal arrPassed)
    Dim o As Object
    Dim NumRows As Long
    Dim NumCols As Long
    
    NumRows = UBound(arrPassed, 1) - LBound(arrPassed, 1) + 1
    NumCols = UBound(arrPassed, 2) - LBound(arrPassed, 2) + 1
    Set o = CreateObject("excel.application")
    With o
        .Visible = True
        .Workbooks.Add
        .Sheets("sheet1").Range("A1").Resize(NumRows, NumCols).Value = arrPassed
    End With
End Sub

By the way, if you want more info, read this
http://www.cpearson.com/excel/ArraysAndRanges.aspx

[Kenneth Hobs]

Similarly:

    .sheets("sheet1").Range("A1").Resize(UBound(arrPassed, 1) + 1, UBound(arrPassed, 2) + 1).Value = arrPassed

[gmaxey]

Kenneth, JKwan

Thanks again to both of your for you time and assistance. To summarize the solutions I suppose I can do something like this:

Sub SolutionsDemonstrated()
Dim arrTest1() As String
Dim arrTest2(3, 1)
  arrTest1 = Split("A|B|C|D", "|")
  arrTest2(0, 0) = "A"
  arrTest2(0, 1) = "Apple"
  arrTest2(1, 0) = "B"
  arrTest2(1, 1) = "Blueberry"
  arrTest2(2, 0) = "C"
  arrTest2(2, 1) = "Cherry"
  arrTest2(3, 0) = "D"
  arrTest2(3, 1) = "Dill pickle"
  WriteToExcel arrTest1
  WriteToExcel arrTest2
End Sub
Sub WriteToExcel(ByVal arrPassed)
Dim o As Object
  Set o = CreateObject("excel.application")
  With o
    .Visible = True
    .Workbooks.Add
    Select Case fcnNumDemensions(arrPassed)
      Case 1
         .sheets("sheet1").Range("A1").Resize(UBound(arrPassed) + 1).Value = .Transpose(arrPassed)
      Case 2
         .sheets("sheet1").Range("A1").Resize(UBound(arrPassed, 1) + 1, UBound(arrPassed, 2) + 1).Value = arrPassed
      Case Else
        'Do nothing
    End Select
    
  End With
End Sub
Function fcnNumDemensions(ByRef arrEvaluate) As Long
Dim lngIndex As Long, lngCheck As Long
  On Error GoTo Err_Return
    For lngIndex = 1 To 60000 'Limit
      'Is error generated?  If so demension doesn't exist.
      lngCheck = LBound(arrEvaluate, lngIndex)
    Next lngIndex
lbl_Exit:
  Exit Function
Err_Return:
  fcnNumDemensions = lngIndex - 1
  Resume lbl_Exit:
End Function

[Kenneth Hobs]

There are occasions where a double Transpose is needed for arrays. When this happens, an Index method is a bit more efficient and shorter in code length. I seldom need either.

Of course dealing with more than 3 dimensions is a bit hard to visualize. For your scenario, I would think that an On Error and using both would suffice. I would set an On Error GoTo 0 have the two lines that may error.

Here is a Microsoft reference showing code a bit similar to Greg's for determining the number of dimensions. http://support.microsoft.com/kb/152288

[Paul_Hossler]

Hi Greg, slight variantion the theme

I assume that you're having Word write the array to Excel??
Is that why you passed the array ByVal and not ByRef?

I added IsArray() and used the LBound(s) and UBounds(s) to .Resize the range just in case sometimes the Base is not 0

Sub MyWriteToExcel(ByVal arrPassed As Variant)
    Dim iNumDims As Long
    Dim x As Long
        
        
    If Not IsArray(arrPassed) Then Exit Sub
        
    iNumDims = 3
    
    On Error GoTo FindNumDims
    x = LBound(arrPassed, iNumDims)
        
    Select Case iNumDims
        Case 1
            ActiveSheet.Cells(1, 1).Resize(1, UBound(arrPassed) - LBound(arrPassed) + 1).Value = arrPassed
        
        Case 2
            ActiveSheet.Cells(1, 1).Resize(UBound(arrPassed, 1) - LBound(arrPassed, 1) + 1, UBound(arrPassed, 2) - LBound(arrPassed, 2) + 1).Value = arrPassed
        Case Else
            MsgBox "More than 2 Dim"
    
    End Select
    
    
    Exit Sub
    
FindNumDims:
    iNumDims = iNumDims - 1
    Resume
End Sub

Paul

[gmaxey]

Paul,

Thanks. All good nuggets to know. I really don't know why I passed it ByVal, but yes they were passed from Word.