Forgone,
There is quite a bit of code below, including two API calls, so you'll have
to test and audit the code extensively (especially since I don't know what
your file/folder structures look like). Keep in mind though, that if you run
the code in its current state, you may get unexpected results, which you'll
have to manually reverse. I suggest debugging the code via F8 (i.e.
Debug|Step Into) and/or F9 (i.e. Debug|Toggle Breakpoint). The code has not
been extensively tested, so again, be sure to test for appropriate results.
Some of the code could be simplified via loops and/or other coding
structures, but I figured that drawing it out might be of more help to you.
Best,
Matthew Herbert
Private Const BIF_RETURNONLYFSDIRS As Long = &H1
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
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
Public Enum FileInformation
Folder
BaseExtName
BaseName
Extension
End Enum
Sub TestingIt()
Dim strFolderOne As String
Dim strFolderTwo As String
Dim strFolderNew As String
Dim strFolder As String
Dim strArrOneFiles() As String
Dim strArrTwoFiles() As String
Dim strTemp As String
Dim strFile As String
Dim strFileOne As String
Dim strFileTwo As String
Dim intCnt As Integer
Dim intSpot As Integer
Dim varMatch As Variant
Dim wkbOne As Workbook
Dim wksOne As Worksheet
Dim wkbTwo As Workbook
Dim wksTwo As Worksheet
Dim strExt As String
Dim strCompare As String
strExt = ".xls"
strCompare = " - salary"
strFolderOne = BrowseForFolder("Get Folder1")
If strFolderOne = "" Or Not IsFolder(strFolderOne) Then
MsgBox "You selected an invalid folder."
Exit Sub
End If
strFolderTwo = BrowseForFolder("Get Folder2")
If strFolderTwo = "" Or Not IsFolder(strFolderTwo) Then
MsgBox "You selected an invalid folder."
Exit Sub
End If
strFolderNew = BrowseForFolder("Get New Output Folder")
If strFolderNew = "" Or Not IsFolder(strFolderNew) Then
MsgBox "You selected an invalid folder."
Exit Sub
End If
strFolderOne = FolderBackslash(strFolderOne)
strFolderTwo = FolderBackslash(strFolderTwo)
strFolderNew = FolderBackslash(strFolderNew)
strFile = Dir(strFolderOne & "*" & strExt)
intCnt = 0
Do Until strFile = vbNullString
ReDim Preserve strArrOneFiles(intCnt)
strTemp = ReturnFileInformation(strFolderOne & strFile, BaseName)
strArrOneFiles(intCnt) = strTemp
intCnt = intCnt + 1
strFile = Dir()
Loop
strFile = Dir(strFolderTwo & "*" & strExt)
intCnt = 0
Do Until strFile = vbNullString
ReDim Preserve strArrTwoFiles(intCnt)
strTemp = ReturnFileInformation(strFolderTwo & strFile, BaseName)
intSpot = InStr(1, strTemp, strCompare, vbTextCompare)
If intSpot <> 0 Then
strTemp = Left(strTemp, intSpot - 1)
strArrTwoFiles(intCnt) = strTemp
intCnt = intCnt + 1
End If
strFile = Dir()
Loop
For intCnt = LBound(strArrOneFiles) To UBound(strArrOneFiles)
strFileOne = strArrOneFiles(intCnt)
varMatch = Application.Match(strFileOne, strArrTwoFiles, 0)
If IsError(varMatch) Then
'copy the file, or rename it?
'FileCopy strFolderOne & strFileOne & strExt, strFolderNew &
strFileOne & strExt
'Name strFolderOne & strFileOne & strExt As strFolderNew &
strFileOne & strExt
Else
'copy wks from Folder2 into Folder1 wkb?
strFileTwo = strArrTwoFiles(varMatch - 1)
strFile = strFolderTwo & strFileTwo & strCompare & strExt
Set wkbTwo = Workbooks.Open(strFile)
Set wksTwo = wkbTwo.Worksheets(1)
strFile = strFolderOne & strFileOne & strExt
Set wkbOne = Workbooks.Open(strFileOne)
Set wksOne = wkbOne.Worksheets(1)
wksTwo.Copy Before:=wksOne
strFile = strFolderTwo & strFileTwo & " - done" & strExt
wkbTwo.SaveAs strFile
wkbOne.Close False
wkbTwo.Close True
End If
Next intCnt
For intCnt = LBound(strArrTwoFiles) To UBound(strArrTwoFiles)
strFileTwo = strArrTwoFiles(intCnt)
varMatch = Application.Match(strFileTwo, strArrOneFiles, 0)
If IsError(varMatch) Then
'copy the file, or rename it?
'FileCopy strFolderTwo & strFileTwo & strCompare & strExt,
strFolderNew & strFileTwo & strExt
'Name strFolderTwo & strFileTwo & strCompare & strExt As
strFolderNew & strFileTwo & strExt
End If
Next intCnt
End Sub
Function BrowseForFolder(Optional strCaption As String = "") As String
Dim BI As BROWSEINFO
Dim strFolderName As String
Dim lngID As Long
Dim lngRes As Long
With BI
.pszDisplayName = String$(256, vbNullChar)
.lpszTitle = strCaption
.ulFlags = BIF_RETURNONLYFSDIRS
End With
strFolderName = String$(256, vbNullChar)
lngID = SHBrowseForFolderA(BI)
If lngID <> 0 Then
lngRes = SHGetPathFromIDListA(lngID, strFolderName)
If lngRes <> 0 Then
BrowseForFolder = Left$(strFolderName, InStr(strFolderName,
vbNullChar) - 1)
End If
End If
End Function
Function IsFolder(strPath As String) As Boolean
Dim strFolder As String
On Error Resume Next
strFolder = Dir(strPath, vbDirectory)
If strFolder <> "" Then
If (GetAttr(strFolder) And vbDirectory) = vbDirectory Then
IsFolder = True
End If
End If
End Function
Function ReturnFileInformation(strFileName As String, _
lngFileInfo As FileInformation) As String
Dim strFolder As String
Dim strBaseExtName As String
Dim strBaseName As String
Dim strExtension As String
Dim intSpot As Integer
intSpot = InStrRev(strFileName, "\", , vbTextCompare)
If intSpot = 0 Then
ReturnFileInformation = ""
Exit Function
End If
strFolder = Left(strFileName, intSpot - 1)
strBaseExtName = Right(strFileName, Len(strFileName) - intSpot)
intSpot = InStrRev(strBaseExtName, ".", , vbTextCompare)
strBaseName = Left(strBaseExtName, intSpot - 1)
strExtension = Right(strBaseExtName, Len(strBaseExtName) - intSpot)
Select Case lngFileInfo
Case Folder
ReturnFileInformation = strFolder
Case BaseExtName
ReturnFileInformation = strBaseExtName
Case BaseName
ReturnFileInformation = strBaseName
Case Extension
ReturnFileInformation = strExtension
End Select
End Function
Function FolderBackslash(strFolder As String) As String
If Right(strFolder, 1) <> "\" Then strFolder = strFolder & "\"
FolderBackslash = strFolder
End Function
