Home | Contact Us | FAQ | Search & Site Map | Link to Us
Sign In | Join | Other 45 Sites in Network
Home
DiscussionsAccessExcelInfoPathOutlookPowerPointPublisherWord
DirectoryUser Groups
Related Topics
Outlook ExpressInternet ExplorerWindowsMS Server ProductsMore Topics ...

MS Office Forum / Excel / New Users / July 2006

Tip: Looking for answers? Try searching our database.

Searching Multiple

Thread view: 
Enable EMail Alerts  Start New Thread
Thread rating: 
SeanAlexander - 17 Jul 2006 13:06 GMT
Hi All,
I need some help with a problem I'm facing.
I have multiple excel sheets (almost 80 separate files) in which I'm
concerned with two specific columns (Say Column A and Column B, both
contain strings, all sheets have the same format) I want to search all
the spreadsheets for a value in Column A, and consequently I want to
know the corresponding value in Column B. Would preferably like to get
these in a format which provides the sheet name and the value from
Column B.
Is there any way to automate this in excel ?
Thanks in advance,
Sean.

Signature

SeanAlexander

Dave Peterson - 17 Jul 2006 15:17 GMT
Does this mean that there is a maximum of a single match in that column?

If yes, then this worked ok for me.

Option Explicit
Public 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

'32-bit API declarations
Declare Function SHGetPathFromIDList Lib "shell32.dll" _
 Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) _
 As Long
Declare Function SHBrowseForFolder Lib "shell32.dll" _
   Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long
Function GetDirectory(Optional Msg) As String
   Dim bInfo As BROWSEINFO
   Dim path As String
   Dim r As Long, x As Long, pos As Integer

'   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

'   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
Sub testme01()
 
   Dim myNames() As String
   Dim fCtr As Long
   Dim myFile As String
   Dim myPath As String
   Dim TempWkbk As Workbook
   Dim wks As Worksheet
   Dim DestCell As Range
   Dim res As Variant
   Dim StringToLookFor As String
   
   StringToLookFor = InputBox(prompt:="what to look for:" & vbLf & _
                       "test" & vbLf & "*test*", _
                       Title:="surround with *'s if other stuff in the cell")
   If Trim(StringToLookFor) = "" Then
       Exit Sub
   End If
   
   myPath = GetDirectory("Select a Folder")
   If myPath = "" Then Exit Sub
   If Right(myPath, 1) <> "\" Then
       myPath = myPath & "\"
   End If
   
   myFile = ""
   On Error Resume Next
   myFile = Dir(myPath & "*.xls")
   On Error GoTo 0
   If myFile = "" Then
       MsgBox "no files found"
       Exit Sub
   End If
   
   Set DestCell = Workbooks.Add(1).Worksheets(1).Range("a1")
   DestCell.Resize(1, 5).Value _
       = Array("Workbook Name", "Worksheet Name", "Address", _
                  "Col A Value", "Col B Value")
   
   Application.ScreenUpdating = False
   
   'get the list of files
   fCtr = 0
   Do While myFile <> ""
       fCtr = fCtr + 1
       ReDim Preserve myNames(1 To fCtr)
       myNames(fCtr) = myFile
       myFile = Dir()
   Loop
   
   If fCtr > 0 Then
       For fCtr = LBound(myNames) To UBound(myNames)
           If LCase(myNames(fCtr)) = LCase(ThisWorkbook.Name) Then
               'do nothing, skip this file
           Else
               Application.StatusBar _
                      = "Processing: " & myNames(fCtr) & " at: " & Now
                     
               Set TempWkbk = Workbooks.Open(Filename:=myPath _
                                  & myNames(fCtr), ReadOnly:=True)
                                 
               For Each wks In TempWkbk.Worksheets
                   res = Application.Match(StringToLookFor, _
                                              wks.Range("a:a"), 0)
                   If IsNumeric(res) Then
                       'found it
                       Set DestCell = DestCell.Offset(1)
                       With DestCell
                           .Value = TempWkbk.FullName
                           .Offset(0, 1).Value = "'" & wks.Name
                           .Offset(0, 2).Value _
                                = wks.Range("a:a")(res).Address(0, 0)
                           .Offset(0, 3).Value = wks.Range("a:a")(res).Value
                           .Offset(0, 4).Value _
                                = wks.Range("a:a")(res).Offset(0, 1).Value
                       End With
                   End If
               Next wks
               
               TempWkbk.Close savechanges:=False
           End If
       Next fCtr
   End If
   
   DestCell.Parent.UsedRange.Columns.AutoFit
   
   With Application
       .ScreenUpdating = True
       .StatusBar = False
   End With
 
End Sub

The first few routines let you select a folder that contains all the files--if
the files are all over the place, copy them to a single file.

That code came from John Walkenbach:
http://j-walk.com/ss/excel/tips/tip29.htm

If you're new to macros, you may want to read David McRitchie's intro at:
http://www.mvps.org/dmcritchie/excel/getstarted.htm

> Hi All,
> I need some help with a problem I'm facing.
[quoted text clipped - 14 lines]
> SeanAlexander's Profile: http://www.excelforum.com/member.php?action=getinfo&userid=27066
> View this thread: http://www.excelforum.com/showthread.php?threadid=562013

Signature

Dave Peterson


Rate this thread:






 
Sign In
Join
My Latest Posts
My Monitored Threads
My Blog
My Photo Gallery
My Profile
My Homepage

Start New Thread
Enable EMail Alerts
Rate this Thread



©2008 Advenet LLC   Privacy Policy - Terms of Use
This website includes both content owned or controlled by Advenet as well as content owned or controlled by third parties.