Here's a macro that I cut and pasted to hopefully fit your needs. Copy this
into a new module.
The macro that should be run is "GetFiles'.
The rest are functions to get various information.
'=== START OF MACRO TO BE COPIED========
'/======================================/
'The purpose of this 'GetFiles' macro is to Select a file, then
' select the folder of the second file with the same name, then
' copy both files to a new workbook
'
'/======================================/
'32-bit API declarations
Private Declare Function SHGetPathFromIDList Lib "shell32.dll" _
Alias "SHGetPathFromIDListA" (ByVal pidl As Long, _
ByVal pszPath As String) As Long
Private Declare Function SHBrowseForFolder Lib "shell32.dll" _
Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) _
As Long
'/======================================/
Private Type BROWSEINFO
hOwner As Long
pidlRoot As Long
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpfn As Long
lParam As Long
iImage As Long
End Type
'/======================================/
Sub GetFiles()
Dim strFirstFile As String, str2ndFolder As String
Dim strFileNameOnly As String, str1stFolder As String
Dim strNewWorkbookName As String, strNewUnNamedWorkbook As String
On Error GoTo err_Sub
'default new workbook name
strNewWorkbookName = "Compare_" & Now()
'get first file to be opened
strFirstFile = GetFirstFileName
'get folder of 2nd file
str2ndFolder = _
GetDirectory("Select Folder location of 2nd file") & "\"
'Get name of file to be imported
strFileNameOnly = GetFileNameOnly(strFirstFile)
'get name of first folder
str1stFolder = GetFirstFolderName(strFirstFile)
'check that 2nd file exists
If FileExists(str2ndFolder & strFileNameOnly) = False Then
MsgBox str1stFolder & strFileNameOnly & " does NOT exist." & _
vbCr & "Process halted", vbCritical + vbOKOnly, "Warning..."
GoTo exit_Sub
End If
'Add a new workbook
Workbooks.Add
strNewUnNamedWorkbook = _
Application.ActiveWorkbook.Name
'open 1st file
Application.Workbooks.Open strFirstFile
'copy to new workbook
Application.ActiveSheet.Copy _
Before:=Workbooks(strNewUnNamedWorkbook).Sheets(1)
'close the 1st file
Windows(strFileNameOnly).Activate
Application.ActiveWorkbook.Close SaveChanges:=False
'open 2nd file
Application.Workbooks.Open str2ndFolder & strFileNameOnly
'copy to new workbook
Application.ActiveSheet.Copy _
Before:=Workbooks(strNewUnNamedWorkbook).Sheets(2)
'close the 2nd file
Windows(strFileNameOnly).Activate
Application.ActiveWorkbook.Close SaveChanges:=False
'goto the new workbook
Windows(strNewUnNamedWorkbook).Activate
exit_Sub:
On Error Resume Next
Exit Sub
err_Sub:
MsgBox "Error has occurred: " & Err.Number & " - " & _
Err.Description
GoTo exit_Sub
End Sub
'/======================================/
Private Function GetFirstFolderName(strName As String) As String
Dim i As Integer
GetFirstFolderName = ""
If Len(strName) > 0 Then
For i = Len(strName) To 1 Step -1
If Mid(strName, i, 1) = "\" Then
GetFirstFolderName = Left(strName, i)
Exit Function
End If
Next i
End If
End Function
'/======================================/
Private Function GetFileNameOnly(strName As String) As String
Dim i As Integer
GetFileNameOnly = ""
If Len(strName) > 0 Then
For i = Len(strName) To 1 Step -1
If Mid(strName, i, 1) = "\" Then
GetFileNameOnly = Right(strName, Len(strName) - i)
Exit Function
End If
Next i
End If
End Function
'/======================================/
Private Function GetFirstFileName() As String
Dim iFilterIndex As Integer
Dim strFilter As String, StrDialogBoxTitle As String
Dim varFileName As Variant
strFilter = "Excel Files (*.xl?),*.xl?," & _
"Comma Separated Files (*.csv),*.csv," & _
"Text_1 Files (*.txt),*.txt," & _
"Text_2 Files (*.prn),*.prn," & _
"All Files (*.*), *.*"
varFileName = ""
'Display Excel Files as default - 1st on StrFilter list above
iFilterIndex = 1
'Set the dialog box caption
StrDialogBoxTitle = "Select First File to Open"
'Get the File Name
varFileName = _
Application.GetOpenFilename(fileFilter:=strFilter, _
FilterIndex:=iFilterIndex, Title:=StrDialogBoxTitle)
If varFileName = False Then
varFileName = ""
End If
GetFirstFileName = varFileName
End Function
'/======================================/
Private Function GetDirectory(Optional Msg) As String
Dim bInfo As BROWSEINFO
Dim iFileSystemDirectoriesOnly As Long
Dim iDialogType As Long
Dim iBrowseForComputers As Long
Dim iBrowseForPrinters As Long
Dim iBrowseIncludesFiles As Long
Dim Path As String
Dim r As Long, x As Long, Pos As Integer
iFileSystemDirectoriesOnly = 0
iDialogType = 0
iBrowseForComputers = 0
iBrowseForPrinters = 0
iBrowseIncludesFiles = 0
'- - - - - - - - - - - - - - - - -
' Only return file system directories.
iFileSystemDirectoriesOnly = &H1
' Dialog style with context menu and resizability
' iDialogType = &H40
' Only returns computers
' iBrowseForComputers = &H1000
' Only return printers
' iBrowseForPrinters = &H2000
' The browse dialog will display files as well as folders
' iBrowseIncludesFiles = &H4000
' Root folder = Desktop
bInfo.pidlRoot = 0&
' Title in the dialog
If IsMissing(Msg) Then
bInfo.lpszTitle = "Select a folder."
Else
bInfo.lpszTitle = Msg
End If
' Type of directory to return
' bInfo.ulFlags = &H1
bInfo.ulFlags = _
iFileSystemDirectoriesOnly + _
iDialogType + _
iBrowseForComputers + _
iBrowseForPrinters + _
iBrowseIncludesFiles
' Display the dialog
x = SHBrowseForFolder(bInfo)
' Parse the result
Path = Space$(512)
r = SHGetPathFromIDList(ByVal x, ByVal Path)
If r Then
Pos = InStr(Path, Chr$(0))
GetDirectory = Left(Path, Pos - 1)
Else
GetDirectory = ""
End If
End Function
'/======================================/
Private Function FileExists(strFileName As String) _
As Boolean
FileExists = False
If Dir(strFileName) <> "" Then
FileExists = True
End If
End Function
'/======================================/
'=== END OF MACRO TO BE COPIED========
HTH,