Sub Write_To_Excel(fn As String, data As Variant, Optional row As Long = 1, Optional col As Long = 1)
Dim didInit As Boolean, writeit As Boolean
writeit = True
If Dir(fn) <> "" Then
If MsgBox("The file " & fn & " exists!" & vbCrLf & _
"Do you wish to overwrite?", vbYesNo, "File Exists!") = vbNo Then
writeit = False
End If
End If
If writeit = True Then
Dim xlsApp As Excel.Application
Dim xlsWb As Excel.Workbook
Dim xlsWs As Excel.Worksheet
Dim i As Long, ii As Long
On Error Resume Next
Set xlsApp = GetObject(, "Excel.application")
If xlsApp Is Nothing Then
didInit = True
Set xlsApp = CreateObject("excel.application")
End If
Set xlsWb = xlsApp.Workbooks.Add
Set xlsWs = xlsWb.Worksheets(1)
For i = 0 To UBound(data)
For ii = 0 To UBound(data(i))
If typename(data(i)(ii)) = "String" Then
xlsWs.Cells(row + i, col + ii).NumberFormat = "@"
Else
xlsWs.Cells(row + i, col + ii).NumberFormat = "General"
End If
xlsWs.Cells(row + i, col + ii) = data(i)(ii)
Next
Next
xlsWb.SaveAs fn
xlsWb.Close
Set xlsWs = Nothing
Set xlsWb = Nothing
If didInit = True Then xlsApp.Quit
Set xlsApp = Nothing
End If
End Sub
Function Read_From_Excel(fn As String, Optional row As Long = 1, Optional col As Long = 1) As Variant
Dim didInit As Boolean
If Dir(fn) <> "" Then
Dim xlsApp As Excel.Application
Dim xlsWb As Excel.Workbook
Dim xlsWs As Excel.Worksheet
Dim i As Long, ii As Long, ocol As Long, rDat(), cDat()
On Error Resume Next
Set xlsApp = GetObject(, "Excel.application")
If xlsApp Is Nothing Then
didInit = True
Set xlsApp = CreateObject("excel.application")
End If
Set xlsWb = xlsApp.Workbooks.Open(fn)
Set xlsWs = xlsWb.Worksheets(1)
ocol = col
Do Until xlsWs.Cells(row, col) = ""
ReDim Preserve rDat(row - 1)
Do Until xlsWs.Cells(row, col) = ""
ReDim Preserve cDat(col - 1)
cDat(col - 1) = xlsWs.Cells(row, col).Value
col = col + 1
Loop
rDat(row - 1) = cDat
row = row + 1: col = ocol
Loop
Read_From_Excel = rDat
xlsWb.Close
Set xlsWs = Nothing
Set xlsWb = Nothing
If didInit = True Then xlsApp.Quit
Set xlsApp = Nothing
End If
End Function
