raeraz
01-31-2008, 05:14 AM
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
=======================================
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
=======================================