Public ifile
Public AFiles()
Sub ImportAll()
Dim CodeBook As String
Let CodeBook = ThisWorkbook.Name
Dim X, Y, Z As Long
Dim ThePath As String
Dim ThePassword As String
Dim TheData(7, 11)
Application.DisplayAlerts = False
Application.EnableEvents = False
Let ThePassword = "test" 'put in the "real" password here; leave blank if no password
Let ThePath = "c:\temp\" 'This is where the files are, Put your desktop path here!
Dir ThePath 'Change directories to the folder where the files are located
ifile = 0
ListFilesInDirectory ThePath, 0
For X = 1 To ifile
If AFiles(X) Like "*.xls*" Then
'use this one, it is a spreadsheet
Workbooks.Open Filename:=AFiles(X), Password:=ThePassword
'here is the section where we have to determine how to select the data to copy, copy it
Y = Y + 1
TheData(Y, 1) = Range("J11").Value
TheData(Y, 2) = Range("K14").Value
TheData(Y, 3) = Range("H78").Value
TheData(Y, 4) = Range("D34").Value
TheData(Y, 5) = Range("G56").Value
TheData(Y, 6) = Range("T67").Value
TheData(Y, 7) = Range("R56").Value
TheData(Y, 8) = Range("W23").Value
TheData(Y, 9) = Range("T45").Value
TheData(Y, 10) = Range("C45").Value
'J11, k14,h78,d34,g56,t67,r56,w23,t45,c45
TheData(Y, 11) = AFiles(X)
'after reading the data in, close the file
ActiveWindow.Close , savechanges:=False
Windows(CodeBook).Activate
Cells(Y, 1).Value = TheData(Y, 11)
For Z = 2 To 11
Cells(Y, Z).Value = TheData(Y, Z - 1)
Next
End If
Next
Beep
Application.DisplayAlerts = True
Application.EnableEvents = True
End Sub
Private Sub ListFilesInDirectory(Directory As String, EraseIt As Integer)
'This is called by the list all files function above.
Dim X As Integer, Y As Integer
Dim StartRow As Integer
Dim aDirs() As String, iDir As Integer, stFile As String
Dim SubName As String
Dim Goback As Integer
Let SubName = "ListInDir"
On Error GoTo handleCancelListInDir
'MsgBox (Directory)
' use Dir function to find files and directories in Directory
' look for directories and build a separate array of them
' note that Dir returns files as well as directories when vbDirectory
' specified
If EraseIt = 1 Then
'Sheets("Control").Select
'Application.GoTo Reference:="FilesToDo"
Application.GoTo Reference:="PathToRename"
X = ActiveCell.Row + 1
Y = ActiveCell.Column + 1
Cells(X, Y).Select
X = ActiveCell.Row
End If
iDir = 0
stFile = Directory & Dir(Directory & "*.*", vbDirectory)
Do While stFile <> Directory
If Right(stFile, 2) = "\." Or Right(stFile, 3) = "\.." Then
' do nothing - GetAttr doesn't like these directories
ElseIf GetAttr(stFile) = vbDirectory Then
' add to local array of directories
iDir = iDir + 1
ReDim Preserve aDirs(iDir)
aDirs(iDir) = stFile
Else
' add to global array of files
ifile = ifile + 1
ReDim Preserve AFiles(ifile)
AFiles(ifile) = stFile
End If
stFile = Directory & Dir()
Loop
' now, for any directories in aDirs call self recursively
If iDir > 0 Then
For iDir = 1 To UBound(aDirs)
ListFilesInDirectory aDirs(iDir) & Application.PathSeparator, 0
Next iDir
End If
'ProgressDetails (SubName)
If EraseIt = 1 Then
StartRow = X
For Y = 1 To ifile
Cells(X, 1).Value = AFiles(Y)
X = X + 1
Next
Cells(StartRow, 1).Select
End If
Exit Sub
handleCancelListInDir:
If Err = 18 Then
Let Goback = MsgBox(prompt:="You interrupted the program by hitting the Escape key. The system will return to the point where you caused this intervention. Thank you. (Note, if you wish to stop the program click Cancel instead of OK)", Title:="FLIR Systems User Intervention", Buttons:=vbYesNoCancel + vbCritical)
Else
Let Goback = MsgBox(prompt:="In Sub " & SubName & ", there is an Error (" & Err.Number & ") of " & Err.Description & ". The system will return to the point where this error was caused. Thank you.", Title:="FLIR User System Error", Buttons:=vbOKCancel + vbCritical)
End If
'DetailsCntr = DetailsCntr + 1
'DetailsArray(DetailsCntr, 1) = "IN " & SubName & ", User had Error " & " and chose to " & Goback
Goback = 1
If Goback = 1 Then 'Selected OK
Resume
ElseIf Goback = 2 Then 'Selected Cancel
Exit Sub
ElseIf Goback = 6 Then 'Selected Yes
Resume
ElseIf Goback = 7 Then 'Selected NO
Resume Next
End If
End Sub
