Importing data into Excel

Question

Is there an easier way of importing data into an Excel array or other data structure? I've tried researching collections but I have found the documentation hard to comprehend.

MSDN

The code I have opens a select file and searches for the column header and then loops through each row storing the data according to header and row variables. I've done this method for many macros in the past but now I am dealing with many many columns and I'm looking for a more advanced way.

Sub Import_NAVRec()
MyPath = Range("b2") 'Defines cell that contains path to source file
Workbooks.Open (MyPath) 'Opens file
Set tempbook = ActiveWorkbook 'Names workbook
LR = Range("A65000").End(xlUp).Row 'finds last row in sourcefile
ReDim aNavRec(1 To LR, 1 To 4) 'Defines NAV Rec array
nRow = 0
 cName = "Accounting Basis"
 CA = Cells.Find(What:=UCase(cName), After:=ActiveCell, LookIn:=xlFormulas, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext).Column
 cName = "Accounting Date"
 cB = Cells.Find(What:=UCase(cName), After:=ActiveCell, LookIn:=xlFormulas, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext).Column
 cName = "Asset Currency"
 cC = Cells.Find(What:=UCase(cName), After:=ActiveCell, LookIn:=xlFormulas, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext).Column
 For r = 2 To LR
 'If Cells(r, cB) = "Trading Gain Loss" Then
 nRow = nRow + 1
 aNavRec(nRow, 1) = Cells(r, CA) 'Fund Number
 aNavRec(nRow, 2) = Cells(r, cB) 'Ledger
 aNavRec(nRow, 3) = Cells(r, cC) 'Balance change
 'End If
 Next r
tempbook.Close
End Sub
Sub Print_output()
Sheets("Output").Select
Set Destination = Range("a2")
Destination.Resize(UBound(aNavRec, 1) + 1, UBound(aNavRec, 2)).Value = aNavRec
End Sub

Answer 1

I propose the following refactoring based on:

• use of arrays to range and viceversa

  though tempered by the fact that you have to deal with possible non contiguous columns range

• use of fully qualified range references

  to both avoid Select/Activate stuff and have full control of which range/worksheet/workbook you're dealing with

• use of Option Explicit statement

  to force explicit declaration of type for ALL variables used in the code

  this extra work earns you back with a lot more control of what you're actually doing and saves you a lot of time in both code debugging and maintenance

• robust function to return a "valid" workbook

  see GetWorkBook() function

`

Option Explicit
Sub Import_NAVRec()
 Dim tempbook As Workbook
 Dim LR As Long, LC As Long, c As Long, nCols As Long
 Dim aNavRec() As Variant 'declare NAV Rec array. it'll be an array of arrays
 Dim headers As String 'declare the variable where you'll put headers of interest
 Set tempbook = GetWorkBook(ActiveSheet.Range("b2")) 'try setting a workbook whose path is in cell "B2" of ActiveSheet
 If tempbook Is Nothing Then Exit Sub 'exit sub if no valid workbook is returned
 headers = "|Accounting Basis|Accounting Date|Asset Currency|" ' set your headers delimited by a "|"
 ReDim aNavRec(1 To UBound(Split(headers, "|")) - 1) ' dim aNavRec to number of headers you want to grab columns of
 With tempbook.ActiveSheet
 LR = .Cells(.Rows.Count, "A").End(xlUp).Row 'find last row in sourcefile column A
 LC = .Cells(1, .Columns.Count).End(xlToLeft).Column 'find last column in sourcefile headers
 For c = 1 To LC 'loop through every column
 If InStr(headers, "|" & .Cells(1, c) & "|") <> 0 Then 'if current column header is bewteen the wanted ones
 nCols = nCols + 1 'update the number of found columns
 aNavRec(nCols) = Application.Transpose(.Range(.Cells(1, c), .Cells(LR, c))) 'store the found column in the variant element in the current index (nCols) of the array. you have to transpose a "column" range to fit into a "horizontal" variant array
 End If
 Next c
 ReDim Preserve aNavRec(1 To nCols) ' redim aNavRec to actual number of headers found nt to grab columns of
 End With
 tempbook.Close (False)
 Print_output Worksheets("Output").Range("a2"), aNavRec 'after closing 'tempbook' the active workbook (and worksheet) is the one we started with
End Sub
Sub Print_output(iniRng As Range, arrays() As Variant)
 Dim i As Long
 With iniRng
 For i = 1 To UBound(arrays)
 iniRng.Offset(, i - 1).Resize(UBound(arrays) + 1).Value = Application.Transpose(arrays(i)) ' you have to transpose back the array to fit it into a "column" range
 Next i
 .CurrentRegion.EntireColumn.AutoFit
 End With
End Sub
Function GetWorkBook(path As String) As Workbook
 ' returns the workbook corresponding to path
 ' checks whether a workbook with the given name and path is already open
 ' if an already open workbook has the same name but different path:
 ' - if it is NOT the active one -> it'llbe closed and the requested one will be opened
 ' - if it IS the active one -> no action will be taken
 '
 ' requires reference to "Microsoft Scripting RuntTime" library
 Dim fso As New FileSystemObject
 Dim f As File
 Dim fName As String
 If Not fso.GetExtensionName(path) Like "xls*" Then Exit Function 'exit if it's not a valid excel file
 If Not fso.FileExists(path) Then Exit Function 'exit if there's no such file
 Set f = fso.GetFile(path) 'get the file corresponding to the now validated path
 fName = fso.GetFileName(path)
 Set GetWorkBook = TrySetWorkbook(fName) 'check whether that workbook is already open
 If GetWorkBook Is Nothing Then 'if no...
 Set GetWorkBook = Workbooks.Open(path) '... open it!
 Else 'if yes...
 If GetWorkBook.FullName <> f.path Then '... and it has a different path from the requested workbook one ...
 ' ... then you should close the already open workbook with the same of the requested one before opening this latter
 If ActiveSheet.Parent.name = fName Then 'if the workbook to close is the active one (!)...
 MsgBox "workbook:" & vbCrLf & vbCrLf & "'" & ActiveSheet.Parent.FullName & "'" _
 & vbCrLf & vbCrLf & "should be closed to open woorkbook:" & vbCrLf & vbCrLf & "'" & f.path _
 & vbCrLf & vbCrLf & vbCrLf & "but the former is the active workbook, so no action will be taken", vbInformation
 Set GetWorkBook = Nothing ' set the return workbook to Nothing so as to have calling sub skip the passed path
 Else 'otherwise...
 Workbooks(fName).Close True '... close (saving changes) the already open one...
 Set GetWorkBook = Workbooks.Open(path) '<~~ ... and finally open the requested one
 End If
 End If
 End If
End Function
Function TrySetWorkbook(path As String) As Workbook
 On Error Resume Next
 Set TrySetWorkbook = Workbooks(path)
End Function

• Raystafarian: Hey, welcome to codereview! Sometimes here it's easier for the asker to learn if, instead of putting what changed all together and then all the code in a block (with comments), each part that changes is explained with the before and after; then the entire block can be put at the end as well. Good answer though!

Answer 2

If you are after spreadsheet data, then you can just import a range into an array. Like so:

Public Sub GetSheetData()
 Dim sheetRange As Range
 Set sheetRange = GetSheetRange
 Dim sheetData As Variant
 sheetData = Array()
 sheetData = sheetRange
 '/ And now whatever was in the top left cell of your sheet 
 '/ Range is in sheetData(1, 1), next row (2, 1) etc.
End Sub
Public Function GetSheetRange() As Range
 Dim headerCell As Range
 Set headerCell = Cells.Find(... '/ Your find criteria here
 Dim firstRow As Long
 firstRow = headerCell.Row
 Dim firstColumn As Long
 firstColumn = headerCell.Column
 Dim lastRow As Long
 lastRow = Cells(Rows.Count, firstColumn).End(xlUp).Row
 Dim lastColumn As Long
 lastColumn = headerCell.Column
 Set GetSheetRange = Range(Cells(firstRow, firstColumn), Cells(lastRow, lastColumn))
End Function

You could also just import the entire sheet into an array and then search the array for your headers. Or whatever else will suit. The above is just a demonstration of syntax.

Also, please make note of the naming, indenting and spacing. Code should be written to be read by other people. Give things descriptive names. Use indentation. Space separate concerns apart from each other.