VBA Open Dialogue Box to Select Multiple Files

[raeraz]

Does anyone know how to take out the function below as the code below looks for excel files in the C: drive folder called "Excel" opens the filles up one at the time , does its code and closes the file, than moves to the next one etc.

I want to tkae out that funtion and put in a Search browse box so the user has option to browse excel files from diff folders /drives. Once files are selected and user preses ok the macro will run and do all the copying and pasting etc , see below in code.

Summary: Need a Excel browse function that allows user to select the excel files for the macro to run on

Your expertise required.

==================================================


Function GetAllFilesInDir(ByVal strDirPath As String) As Variant
' Loop through the directory specified in strDirPath and save each
' file name in an array, then return that array to the calling
' procedure.
' Return False if strDirPath is not a valid directory.
Dim strTempName As String
Dim varFiles() As Variant
Dim lngFileCount As Long

On Error GoTo GetAllFiles_Err

' Make sure that strDirPath ends with a "\" character.
If Right$(strDirPath, 1) <> "\" Then
strDirPath = strDirPath & "\"
End If

' Make sure strDirPath is a directory.
If GetAttr(strDirPath) = vbDirectory Then
strTempName = Dir(strDirPath, vbDirectory)
Do Until Len(strTempName) = 0
' Exclude ".", "..".
If (strTempName <> ".") And (strTempName <> "..") Then
' Make sure we do not have a sub-directory name.
If (GetAttr(strDirPath & strTempName) _
And vbDirectory) <> vbDirectory Then
' Increase the size of the array
' to accommodate the found filename
' and add the filename to the array.
ReDim Preserve varFiles(lngFileCount)
varFiles(lngFileCount) = strTempName
lngFileCount = lngFileCount + 1
End If
End If
' Use the Dir function to find the next filename.
strTempName = Dir()
Loop
' Return the array of found files.
GetAllFilesInDir = varFiles
End If
GetAllFiles_End:
Exit Function
GetAllFiles_Err:
GetAllFilesInDir = False
Resume GetAllFiles_End
End Function
' Automation of importing Quality Audit Sheets into Report

Sub Import_Quality_Audit_Sheets()
Dim intPosition As Integer
Dim FilePath As String
Dim FileNames() As Variant
' Var to check first three chars
Dim CheckFile As String
Dim FileCharCheck As String
' Put your files in this list... run a function to create this array by
'telling the function where to look for the files.

FileNames = GetAllFilesInDir("C:\Excel")
'Store the Excel files in this directory. This is where the macro will look for the Excel Files
FilePath = "C:\Excel\"
Dim exlApp As Object
Dim exlDoc As Object
Set exlApp = CreateObject("Excel.Application")
' This is the loop....
For intPosition = LBound(FileNames) To UBound(FileNames)
' Open up the file that you want to use
Set exlDoc = exlApp.Workbooks.Open(FilePath + FileNames(intPosition))
exlApp.Visible = True
' Need to check cell C4 the first three chars...
CheckFile = exlApp.Range("C4").Value
' This is the first three chars of cell C4
FileCharCheck = Mid(CheckFile, 1, 3)
' Get range to copy and paste
exlApp.Range("C4:C34").Select
exlApp.Selection.Copy

If FileCharCheck = "NTH" Then
'Paste the data into North database
Sheets("North").Select
Range("E4").Select
ActiveSheet.Paste

Sheets("North").Paste
Columns("F:F").Select
Columns("F:F").EntireColumn.AutoFit

'Get ready for next file to be pasted
Selection.Insert Shift:=xlToRight
Range("E4:E34").Select
Selection.Copy
ActiveWindow.SmallScroll Down:=-12
Range("F4").Select
ActiveSheet.Paste
Range("F4").Select
Selection.Interior.ColorIndex = 15
Columns("F:F").EntireColumn.AutoFit

'Alligning the column to centre

Columns("F:F").Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With


Range("E4:E34").Select
Application.CutCopyMode = False
Selection.ClearContents
ElseIf FileCharCheck = "CSY" Then
'Paste the data into Core Systems database
Sheets("Core Systems").Select
Range("E4:E34").Select
ActiveSheet.Paste
Sheets("Core Systems").Paste
Columns("F:F").Select
Columns("F:F").EntireColumn.AutoFit

'Get ready for next file to be pasted
Columns("F:F").Select
Selection.Insert Shift:=xlToRight
Range("E4:E34").Select
Selection.Copy
ActiveWindow.SmallScroll Down:=-12
Range("F4").Select
ActiveSheet.Paste
Range("F4").Select
Selection.Interior.ColorIndex = 15
Columns("F:F").EntireColumn.AutoFit

'Alligning the column to centre

Columns("F:F").Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With

Range("E4:E34").Select
Application.CutCopyMode = False
Selection.ClearContents

ElseIf FileCharCheck = "DCP" Then
'Paste the data into DCCP Worksheet
Sheets("DCCP").Select
Range("E4").Select
ActiveSheet.Paste
Sheets("DCCP").Paste


'Get ready for next file to be pasted
Columns("F:F").Select
Selection.Insert Shift:=xlToRight
Range("E4:E34").Select
Selection.Copy
ActiveWindow.SmallScroll Down:=-12
Range("F4").Select
ActiveSheet.Paste
Range("F4").Select
Selection.Interior.ColorIndex = 15
Columns("F:F").EntireColumn.AutoFit

'Alligning the column to centre

Columns("F:F").Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With


Range("E4:E34").Select
Application.CutCopyMode = False
Selection.ClearContents

ElseIf FileCharCheck = "EIF" Then
'Paste the data into EIF worksheets
Sheets("EIF").Select
Range("E4").Select
ActiveSheet.Paste
Sheets("EIF").Paste

'Get ready for next file to be pasted
Columns("F:F").Select
Selection.Insert Shift:=xlToRight
Range("E4:E34").Select
Selection.Copy
ActiveWindow.SmallScroll Down:=-12
Range("F4").Select
ActiveSheet.Paste
Range("F4").Select
Selection.Interior.ColorIndex = 15
Columns("F:F").EntireColumn.AutoFit

'Alligning the column to centre

Columns("F:F").Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With


Range("E4:E34").Select
Application.CutCopyMode = False
Selection.ClearContents


ElseIf FileCharCheck = "TRP" Then
'Paste the data into Tech Refresh Worksheet
Sheets("Tech Refresh").Select
Range("E4").Select
ActiveSheet.Paste
Sheets("Tech Refresh").Paste


'Get ready for next file to be pasted
Columns("F:F").Select
Selection.Insert Shift:=xlToRight
Range("E4:E34").Select
Selection.Copy
ActiveWindow.SmallScroll Down:=-12
Range("F4").Select
ActiveSheet.Paste
Range("F4").Select
Selection.Interior.ColorIndex = 15
Columns("F:F").EntireColumn.AutoFit

'Alligning the column to centre

Columns("F:F").Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With


Range("E4:E34").Select
Application.CutCopyMode = False
Selection.ClearContents

ElseIf FileCharCheck = "STH" Then
'Paste the data into South Worksheet
Sheets("South").Select
Range("E4").Select
ActiveSheet.Paste
Sheets("South").Paste

'Get ready for next file to be pasted

'Get ready for next file to be pasted
Columns("F:F").Select
Selection.Insert Shift:=xlToRight
Range("E4:E34").Select
Selection.Copy
ActiveWindow.SmallScroll Down:=-12
Range("F4").Select
ActiveSheet.Paste
Range("F4").Select
Selection.Interior.ColorIndex = 15
Columns("F:F").EntireColumn.AutoFit

'Alligning the column to centre

Columns("F:F").Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With


Range("E4:E34").Select
Application.CutCopyMode = False
Selection.ClearContents

Else

' None of the characters were recognised so do something....
MsgBox "Check Audit sheet in Cell C4 to ensure it has correct Programme Code eg CSY_22AU_Plan "

End If

Next
exlApp.Quit
Set exlApp = Nothing
'Files have been imported now deletion of E Column in Programme Worksheets to tidy it up
Sheets("Core Systems").Select
Columns("E:E").Select
Selection.Delete Shift:=xlToLeft
Sheets("DCCP").Select
Columns("E:E").Select
Selection.Delete Shift:=xlToLeft
Sheets("North").Select
Columns("E:E").Select
Selection.Delete Shift:=xlToLeft
Sheets("EIF").Select
Columns("E:E").Select
Selection.Delete Shift:=xlToLeft
Sheets("Tech Refresh").Select
Columns("E:E").Select
Selection.Delete Shift:=xlToLeft
Sheets("South").Select
Columns("E:E").Select
Selection.Delete Shift:=xlToLeft
Sheets("Core Systems").Select
End Sub
=======================================

[Bob Phillips]

ONly slightly tested



Public Sub Import_Quality_Audit_Sheets()
Dim FileNames() As Variant
Dim intPosition As Integer
Dim FilePath As String
' Var to check first three chars
Dim CheckFile As String
Dim FileCharCheck As String
Dim exlApp As Object
Dim exlDoc As Object

' Put your files in this list... run a function to create this array by
'telling the function where to look for the files.
FilePath = "C:\Excel\"
FileNames = GetAllFilesInDir(FilePath)
'Store the Excel files in this directory. This is where the macro will look for the Excel Files
Set exlApp = CreateObject("Excel.Application")

' This is the loop....
For intPosition = LBound(FileNames) To UBound(FileNames)
' Open up the file that you want to use
Set exlDoc = exlApp.Workbooks.Open(FileNames(intPosition))
exlApp.Visible = True
' Need to check cell C4 the first three chars...
Select Case Mid(exlApp.Range("C4").Value, 1, 3)

Case "NTH": UpdateSheet Worksheets("North"), exlApp.Range("C4:C34")

Case "CSY": UpdateSheet Worksheets("Core Systems"), exlApp.Range("C4:C34")

Case "DCP": UpdateSheet Worksheets("DCCP"), exlApp.Range("C4:C34")

Case "EIF": UpdateSheet Worksheets("EIF"), exlApp.Range("C4:C34")

Case "TRP": UpdateSheet Worksheets("Tech Refresh"), exlApp.Range("C4:C34")

Case "STH": UpdateSheet Worksheets("South"), exlApp.Range("C4:C34")

Case Else
' None of the characters were recognised so do something....
MsgBox "Check Audit sheet in Cell C4 to ensure it has correct Programme Code eg CSY_22AU_Plan "
End Select

Next

exlApp.Quit
Set exlApp = Nothing
'Files have been imported now deletion of E Column in Programme Worksheets to tidy it up
Sheets("Core Systems").Columns("E:E").Delete Shift:=xlToLeft
Sheets("DCCP").Columns("E:E").Delete Shift:=xlToLeft
Sheets("North").Columns("E:E").Delete Shift:=xlToLeft
Sheets("EIF").Columns("E:E").Delete Shift:=xlToLeft
Sheets("Tech Refresh").Columns("E:E").Delete Shift:=xlToLeft
Sheets("South").Columns("E:E").Delete Shift:=xlToLeft
Sheets("Core Systems").Select
End Sub

Private Function GetAllFilesInDir(ByVal strDirPath As String) As Variant
Dim i As Long
Dim tmp As Variant

If Right(strDirPath, 1) <> "\" Then

strDirPath = strDirPath & "\"
End If

With Application.FileDialog(msoFileDialogOpen)
.AllowMultiSelect = True
.InitialFileName = strDirPath

.Show

' Display paths of each file selected
If .SelectedItems.Count > 0 Then

ReDim tmp(1 To .SelectedItems.Count)
For i = 1 To .SelectedItems.Count

tmp(i) = .SelectedItems(i)
Next i
GetAllFilesInDir = tmp
Else

GetAllFilesInDir = -1
End If
End With
End Function

Private Sub UpdateSheet(ByRef sh As Worksheet, ByVal Target As Range)

With sh

Target.Copy .Range("E4")

With .Columns("F:F")
.AutoFit
'Get ready for next file to be pasted
.Insert Shift:=xlToRight
End With

.Range("E4:E34").Copy .Range("F4")
.Range("F4").Interior.ColorIndex = 15

'Alligning the column to centre
With .Columns("F:F")
.AutoFit
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
End With

.Range("E4:E34").ClearContents
End With

End Sub

[raeraz]

The code above still has the same function.

I need open dialogue box which allows user to select multiple excel files and run the macro on those selected excel files. After its finished displayed which excel files were imported succesfully and which ones failed.

[rory]

Did you try it?

[raeraz]

Yes I did. The macro opens a box to search for the files in the C:Excel Folder. I DO NOT WANT THIS. I want a search dialogue box where it gives the user browse box to search excel files from diff folders and drives on the computer and once they are all selected click Open and than the macro will start and do all the copying and pasting etc.

Your help much appreciated

[Bob Phillips]

What one file from one folder and another file from a different folder?

[raeraz]

Yes , sometimes it can be 4 excel files from one folder , 3 from another folder, on various drives.
Some weeks there might just only be one file in one folder.

This option should give the user to browse and select multiple files from diff folders.

Thanks again for your response

[Bob Phillips]

The code I gave you will allow selecting fron just ONE folder, so you will need to drive a loop calling that over and over accumulating the files until the user hits cancel. But it will be a real mess, I would suggest you re-organise your data.

[raeraz]

Thanks for the response. Their surely must be a way to create a function where it gives user an option to select multiple excel files, hold them in an array and work through them until it reaches the last file and than the macro will end.

[raeraz]

Not v good at VBA but have found the following code that might do the trick.

Just need a way to fit it into my code so it runs the whole code on the selected files.

Open Excel Files - Open Dialog - GetOpenFilename Method (http://vbadud.blogspot.com/2007/04/open-excel-files-open-dialog.html)
=============================================

Sub Open_Excel_File_Thru_VBA()


Dim arTemp() As Variant

Dim lRet

On Error GoTo Err_Clr

'Default method Uses Open Dialog To Show the Files
lRet = Application.GetOpenFilename

'Select Multiple Files - Get Multiple Files as Input
' An array can be used to get the multiple excel files selected by user
arTemp = Application.GetOpenFilename(FileFilter:="Excel files (*.xls), *.xls", MultiSelect:=True)
If UBound(arTemp) = 0 Then
MsgBox "Select a File Please!!!"
End If


Err_Clr:
If Err <> 0 Then
Err.Clear
Resume Next
End If
End Sub
===================================