Add worksheet

[gibbo1715]

I dont think this is as simple as it sounds

Ok, I have a master workbook containing a number of worksheets.

What I need to be able to do is as follows

1. Use vba to search a directory that contains a number of sub folders

2. Each subfolder contains an excel workbook with one spreadsheet, this has the same name as the sub folder, I need to select this.

3. I then need to import that worksheet into my workbook and delete the original

Any ideas on any of the above would be most welcome

Cheers

Gibbo

Ok i think i ve made a start along the right lines, how can i select the right file from here then


Option Compare Text
Option Explicit

Private Const BIF_RETURNONLYFSDIRS As Long = &H1
Private Const BIF_DONTGOBELOWDOMAIN As Long = &H2
Private Const BIF_RETURNFSANCESTORS As Long = &H8
Private Const BIF_BROWSEFORCOMPUTER As Long = &H1000
Private Const BIF_BROWSEFORPRINTER As Long = &H2000
Private Const BIF_BROWSEINCLUDEFILES As Long = &H4000
Private Const MAX_PATH As Long = 260
Type BrowseInfo
hOwner As Long
pidlRoot As Long
pszDisplayName As String
lpszINSTRUCTIONS As String
ulFlags As Long
lpfn As Long
lParam As Long
iImage As Long
End Type
Type SHFILEOPSTRUCT
hwnd As Long
wFunc As Long
pFrom As String
pTo As String
fFlags As Integer
fAnyOperationsAborted As Boolean
hNameMappings As Long
lpszProgressTitle As String
End Type
Declare Function SHGetPathFromIDListA Lib "shell32.dll" ( _
ByVal pidl As Long, _
ByVal pszBuffer As String) As Long
Declare Function SHBrowseForFolderA Lib "shell32.dll" ( _
lpBrowseInfo As BrowseInfo) As Long

Function BrowseFolder(Optional Caption As String = "") As String
Dim BrowseInfo As BrowseInfo
Dim FolderName As String
Dim ID As Long
Dim Res As Long
With BrowseInfo
.hOwner = 0
.pidlRoot = 0
.pszDisplayName = String$(MAX_PATH, vbNullChar)
.lpszINSTRUCTIONS = Caption
.ulFlags = BIF_RETURNONLYFSDIRS
.lpfn = 0
End With
FolderName = String$(MAX_PATH, vbNullChar)
ID = SHBrowseForFolderA(BrowseInfo)
If ID Then
Res = SHGetPathFromIDListA(ID, FolderName)
If Res Then
BrowseFolder = Left$(FolderName, InStr(FolderName, _
vbNullChar) - 1)
End If
End If
End Function

Sub Import()
Dim Search As String
Dim Prompt As String
Dim Title As String
Dim FPath() As String
Dim FName() As String
Dim Path As String
Dim FileName As String
Dim WS As Worksheet
Path = BrowseFolder("Select A Folder")
If Path = "" Then
Prompt = "You didn't select a folder. The procedure has been canceled."
Title = "Procedure Canceled"
MsgBox Prompt, vbCritical, Title
Exit Sub
End If
End Sub

[Killian]

I had a workbook that does a similar thibg so I've adapted it.
You'll need to check the code (the constant for the path, for example) and I haven't done anything about deleting the old worksheet/file

[gibbo1715]

Thanks i ll have a look when i finish work as i cant open zip files here

I managed to figure it out, heres the code i ended up with for those with a similar problem

Gibbo


Option Explicit

Function BrowseForFolder(Optional OpenAt As Variant) As Variant
'Function purpose: To Browser for a user selected folder.
'If the "OpenAt" path is provided, open the browser at that directory
'NOTE: If invalid, it will open at the Desktop level
Dim ShellApp As Object
'Create a file browser window at the default folder
Set ShellApp = CreateObject("Shell.Application"). _
BrowseForFolder(0, "Please choose a folder", 0, "X:\1715")
'Set the folder to that selected. (On error in case cancelled)
On Error Resume Next
BrowseForFolder = ShellApp.self.Path
On Error GoTo 0
'Destroy the Shell Application
Set ShellApp = Nothing
'Check for invalid or non-entries and send to the Invalid error
'handler if found
'Valid selections can begin L: (where L is a letter) or
'\\ (as in \\servername\sharename (file://\servernamesharename). All others are invalid
Select Case Mid(BrowseForFolder, 2, 1)
Case Is = ":"
If Left(BrowseForFolder, 1) = ":" Then GoTo Invalid
Case Is = ""
If Not Left(BrowseForFolder, 1) = "" Then GoTo Invalid
Case Else
GoTo Invalid
End Select
Exit Function
Invalid:
'If it was determined that the selection was invalid, set to False
BrowseForFolder = False
End Function

Sub Import()
Dim Search As String
Dim Prompt As String
Dim Title As String
Dim FPath() As String
Dim FName() As String
Dim Path As String
Dim FileName As String
Dim CurWorkbook As String
CurWorkbook = ThisWorkbook.Name
Path = BrowseForFolder("Select A Folder")
If Path = "" Then
Prompt = "You didn't select a folder. The procedure has been canceled."
Title = "Procedure Canceled"
MsgBox Prompt, vbCritical, Title
Exit Sub
End If
FileName = dir(Path, vbDirectory)
Workbooks.Open FileName:=Path & "" & FileName & ".xls"
Sheets(FileName).Copy _
After:=Workbooks(CurWorkbook).Sheets("Chart")
Workbooks(FileName).Activate
Application.DisplayAlerts = False
ActiveWorkbook.ChangeFileAccess xlReadOnly
Kill ActiveWorkbook.FullName
ActiveWorkbook.Close False
Application.DisplayAlerts = True
Workbooks(CurWorkbook).Activate
End Sub