sheexin
06-15-2015, 09:02 PM
Hello!
I am really new with VBA and have been trying to solve this problem for ages, but to no avail. I use a Mac Excel 2011. Would appreciate any help or advice!
Essentially: I have a master folder of multiple excel files which have ID numbers, and various data such as Name, Description, Price and so on. The information is allocated in a table format, so column A has ID numbers, B has Names, etc. I would like to create a new excel file outside the folder which would allow me to key in ID numbers into a certain column. The VBA should match the ID with those in the master folder, and allow me to extract the corresponding and necessary information accordingly.
1. Take 1 ID at a time from the list in Book1.xls
2. Search the entire master folder, each file, column ____ until it finds a match.
3. Once it finds a match, I can select copy columns ____ from matching workbook to ____ of book1.xls.
4. Stop searching and go back to the list and get the next item to search again.
I have found someone with a similar problem before on this forum, but I can't seem to run the VBA. The thread can be found here: www(dot)vbaexpress(dot)com/forum/showthread.php?10772-Solved-Difficult-Macro-to-search-multiple-workbooks-for-a-match
and the code used:
Sub SearchandDostuff()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
'dimension variables
Dim wb As Workbook, wbCheck As Workbook, strID As String
Dim wsTO As Worksheet, wsFROM As Worksheet, i As Long, pos As Long
Dim folder As String, file As String, Path As String
Dim c As Range, rngMatch As Range, a As Range, rngFrom As Range
Dim Matched As Boolean, ID As Range, counter As Integer
'folder to loop through
folder = BrowseForFolder
'set destination info
Set wsTO = Workbooks("Book1.xls").Sheets("Sheet1") '<<== name your file and sheet
'set the range list, can be re-written to Range("C2:C100") and set to fit
With wsTO
Set rngMatch = .Range("C2:C" & .Cells(.Rows.Count, 3).End(xlUp).Row)
End With
MsgBox rngMatch.Address
For Each ID In rngMatch
Matched = False
'Start FileSearch
With Application.FileSearch
.LookIn = folder
.Filename = "*.xls"
.FileType = msoFileTypeExcelWorkbooks
.SearchSubFolders = False
.Execute
If .Execute > 0 Then
'loop through all found files
For i = 1 To .FoundFiles.Count
'set incidental variables
pos = InStrRev(.FoundFiles(i), "\")
file = Right(.FoundFiles(i), Len(.FoundFiles(i)) - pos)
Path = Left(.FoundFiles(i), pos)
'check if workbook is open. if so, set variable to it, else open it
If IsWbOpen(file) Then
Set wb = Workbooks(file)
If wb.Name = ThisWorkbook.Name Then GoTo SkipME
Else
Set wb = Workbooks.Open(Path & file)
End If
Dim shchk As Boolean
shchk = False
With wb
'set worksheets to look in and if matched copy data from S,T to D,E
'find the sheet with SET in the left side of the name
For Each s In Worksheets
If UCase(Left(s.Name, 3)) = "SET" Then
Set wsFROM = Sheets(s.Name)
shchk = True
Exit For
End If
Next s
End With
If shchk = False Then GoTo SkipME
strID = ID.Text
Set rngFrom = wsFROM.Range(Cells(2, 11), Cells(Rows.Count, 11).End(xlUp))
''check for the ID column?
Set c = rngFrom.Find(strID) 'if a match is found we have the right workbook
If Not c Is Nothing Then 'if a match is found
'copy data from S and T to D and E
'set the range of column C for source list to find
ID.Offset(, 1).Resize(1, 2) = c.Offset(, 8).Resize(1, 2).Value
Matched = True
End If 'end If for the first check
If Matched = True Then Exit For 'if a match is found, exit file search loop
SkipME:
wb.Close False
Next i 'next file
End If
End With 'end with application filesearch
Next ID 'go to the next ID
Set wsTO = Nothing: Set wsFROM = Nothing: Set a = Nothing
Set c = Nothing: Set wb = Nothing
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
Function IsWbOpen(wbName As String) As Boolean
On Error Resume Next
IsWbOpen = Len(Workbooks(wbName).Name)
End Function
Function BrowseForFolder(Optional OpenAt As Variant) As Variant
'''Code from kpuls, Knowledge base submission
Dim ShellApp As Object
Set ShellApp = CreateObject("Shell.Application"). _
BrowseForFolder(0, "Please choose a folder", 0, OpenAt)
On Error Resume Next
BrowseForFolder = ShellApp.self.Path
On Error GoTo 0
Set ShellApp = Nothing
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:
End Function
Whenever I run the code, it shows run time error 429, Active X component can't create object and this is highlighted:
Set ShellApp = CreateObject("Shell.Application"). _BrowseForFolder(0, "Please choose a folder", 0, OpenAt)
I would appreciate it if anyone who creates the code could explain it to me as well, in case I need to do some tweaking! Thanks!
I am really new with VBA and have been trying to solve this problem for ages, but to no avail. I use a Mac Excel 2011. Would appreciate any help or advice!
Essentially: I have a master folder of multiple excel files which have ID numbers, and various data such as Name, Description, Price and so on. The information is allocated in a table format, so column A has ID numbers, B has Names, etc. I would like to create a new excel file outside the folder which would allow me to key in ID numbers into a certain column. The VBA should match the ID with those in the master folder, and allow me to extract the corresponding and necessary information accordingly.
1. Take 1 ID at a time from the list in Book1.xls
2. Search the entire master folder, each file, column ____ until it finds a match.
3. Once it finds a match, I can select copy columns ____ from matching workbook to ____ of book1.xls.
4. Stop searching and go back to the list and get the next item to search again.
I have found someone with a similar problem before on this forum, but I can't seem to run the VBA. The thread can be found here: www(dot)vbaexpress(dot)com/forum/showthread.php?10772-Solved-Difficult-Macro-to-search-multiple-workbooks-for-a-match
and the code used:
Sub SearchandDostuff()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
'dimension variables
Dim wb As Workbook, wbCheck As Workbook, strID As String
Dim wsTO As Worksheet, wsFROM As Worksheet, i As Long, pos As Long
Dim folder As String, file As String, Path As String
Dim c As Range, rngMatch As Range, a As Range, rngFrom As Range
Dim Matched As Boolean, ID As Range, counter As Integer
'folder to loop through
folder = BrowseForFolder
'set destination info
Set wsTO = Workbooks("Book1.xls").Sheets("Sheet1") '<<== name your file and sheet
'set the range list, can be re-written to Range("C2:C100") and set to fit
With wsTO
Set rngMatch = .Range("C2:C" & .Cells(.Rows.Count, 3).End(xlUp).Row)
End With
MsgBox rngMatch.Address
For Each ID In rngMatch
Matched = False
'Start FileSearch
With Application.FileSearch
.LookIn = folder
.Filename = "*.xls"
.FileType = msoFileTypeExcelWorkbooks
.SearchSubFolders = False
.Execute
If .Execute > 0 Then
'loop through all found files
For i = 1 To .FoundFiles.Count
'set incidental variables
pos = InStrRev(.FoundFiles(i), "\")
file = Right(.FoundFiles(i), Len(.FoundFiles(i)) - pos)
Path = Left(.FoundFiles(i), pos)
'check if workbook is open. if so, set variable to it, else open it
If IsWbOpen(file) Then
Set wb = Workbooks(file)
If wb.Name = ThisWorkbook.Name Then GoTo SkipME
Else
Set wb = Workbooks.Open(Path & file)
End If
Dim shchk As Boolean
shchk = False
With wb
'set worksheets to look in and if matched copy data from S,T to D,E
'find the sheet with SET in the left side of the name
For Each s In Worksheets
If UCase(Left(s.Name, 3)) = "SET" Then
Set wsFROM = Sheets(s.Name)
shchk = True
Exit For
End If
Next s
End With
If shchk = False Then GoTo SkipME
strID = ID.Text
Set rngFrom = wsFROM.Range(Cells(2, 11), Cells(Rows.Count, 11).End(xlUp))
''check for the ID column?
Set c = rngFrom.Find(strID) 'if a match is found we have the right workbook
If Not c Is Nothing Then 'if a match is found
'copy data from S and T to D and E
'set the range of column C for source list to find
ID.Offset(, 1).Resize(1, 2) = c.Offset(, 8).Resize(1, 2).Value
Matched = True
End If 'end If for the first check
If Matched = True Then Exit For 'if a match is found, exit file search loop
SkipME:
wb.Close False
Next i 'next file
End If
End With 'end with application filesearch
Next ID 'go to the next ID
Set wsTO = Nothing: Set wsFROM = Nothing: Set a = Nothing
Set c = Nothing: Set wb = Nothing
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
Function IsWbOpen(wbName As String) As Boolean
On Error Resume Next
IsWbOpen = Len(Workbooks(wbName).Name)
End Function
Function BrowseForFolder(Optional OpenAt As Variant) As Variant
'''Code from kpuls, Knowledge base submission
Dim ShellApp As Object
Set ShellApp = CreateObject("Shell.Application"). _
BrowseForFolder(0, "Please choose a folder", 0, OpenAt)
On Error Resume Next
BrowseForFolder = ShellApp.self.Path
On Error GoTo 0
Set ShellApp = Nothing
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:
End Function
Whenever I run the code, it shows run time error 429, Active X component can't create object and this is highlighted:
Set ShellApp = CreateObject("Shell.Application"). _BrowseForFolder(0, "Please choose a folder", 0, OpenAt)
I would appreciate it if anyone who creates the code could explain it to me as well, in case I need to do some tweaking! Thanks!