downtown1933
New Member
- Joined
- Aug 28, 2012
- Messages
- 12
I will try to be as thorough as i possibly can. My knowledge of VBA is basic. I can write small, basic loops & functions to manipulate data and tables, however, this one falls beyond my capabilities. Now to explain whats going on:
First, I found two macros which I thought would make my life at work significantly easier (I will attach). I have slightly modified them both to make them function specifically for what I wanted them to do..Keeping in mind, I could not have written anything like this just yet, if there is a better or more efficient way of coding any part of either, your input will be greatly appreciated.
The first macro was meant to pull multiple xls files from a specific folder, open or paste all of them into a single workbook, each file on a separate sheet. If a file being pulled contained multiple sheets, those should be imported as well, also separated by worksheets. The xls files being pulled can range anywhere from 10 rows of data in one column to 20,000 rows and 30 columns.
The second macro is basically to search for a string throughout the entire workbook.. The unique aspect of this one is that it uses "sheet1" (or should) to return all results. To be more specific, after entering a keyword to search, it returns the address along with the entire row of data around that particular string.
There is not necessarily "one problem" per say, but I guess I can generalize with this.. It does not run very smoothly at all..
The search macro works sometimes, and not others. It may give an error or it may just return "not found." Which is a problem considering I have only searched values I know are existent for the sake of testing. The "combine file" macro wouldn't work initially because "there are more rows and or columns in the files being pulled than my workbook" (wording may be off there, sorry) I had to download the zip containing his example before it actually ran the first time. Which it did great! After successfully pulling files for the first time, I tested the search tool. Sometimes successful, others not. When it came time for test #2, i deleted the sheets which were just imported until i was left only with the "search word" sheet. Ran my combinefile macro, and nothing.. I exited without saving and repeated the process again with the same results. Any help with getting these two pieces of code to run together smoothly and consistently would be greatly appreciated. Once again, I am fairly new to VBA, but I understand basics and am not affraid of reading up on a topic. Any and all comments, help or ideas are very much welcome. Thanks again in advance!
1st macro is the "Searchword" and 2nd is the "CombineFile" macro:
(CombineFile)
First, I found two macros which I thought would make my life at work significantly easier (I will attach). I have slightly modified them both to make them function specifically for what I wanted them to do..Keeping in mind, I could not have written anything like this just yet, if there is a better or more efficient way of coding any part of either, your input will be greatly appreciated.
The first macro was meant to pull multiple xls files from a specific folder, open or paste all of them into a single workbook, each file on a separate sheet. If a file being pulled contained multiple sheets, those should be imported as well, also separated by worksheets. The xls files being pulled can range anywhere from 10 rows of data in one column to 20,000 rows and 30 columns.
The second macro is basically to search for a string throughout the entire workbook.. The unique aspect of this one is that it uses "sheet1" (or should) to return all results. To be more specific, after entering a keyword to search, it returns the address along with the entire row of data around that particular string.
There is not necessarily "one problem" per say, but I guess I can generalize with this.. It does not run very smoothly at all..
The search macro works sometimes, and not others. It may give an error or it may just return "not found." Which is a problem considering I have only searched values I know are existent for the sake of testing. The "combine file" macro wouldn't work initially because "there are more rows and or columns in the files being pulled than my workbook" (wording may be off there, sorry) I had to download the zip containing his example before it actually ran the first time. Which it did great! After successfully pulling files for the first time, I tested the search tool. Sometimes successful, others not. When it came time for test #2, i deleted the sheets which were just imported until i was left only with the "search word" sheet. Ran my combinefile macro, and nothing.. I exited without saving and repeated the process again with the same results. Any help with getting these two pieces of code to run together smoothly and consistently would be greatly appreciated. Once again, I am fairly new to VBA, but I understand basics and am not affraid of reading up on a topic. Any and all comments, help or ideas are very much welcome. Thanks again in advance!
1st macro is the "Searchword" and 2nd is the "CombineFile" macro:
Code:
Option Compare Text
Option Explicit
Public Sub DoFindAll()
FindAll "", "True"
End Sub
Public Sub FindAll(Search As String, Reset As Boolean)
Dim WB As Workbook
Dim WS As Worksheet
Dim Cell As Range
Dim Prompt As String
Dim Title As String
Dim FindCell() As String
Dim FindSheet() As String
Dim FindWorkBook() As String
Dim FindPath() As String
Dim FindText() As String
Dim Counter As Long
Dim FirstAddress As String
Dim Path As String
If Search = "" Then
Prompt = "What do you want to search for in the worbook: " & _
vbNewLine & vbNewLine & Path
Title = "Search Criteria Input"
Search = InputBox(Prompt, Title, "Enter search term")
If Search = "" Then
GoTo Cancelled
End If
End If
Application.EnableEvents = False
Application.DisplayAlerts = False
Application.ScreenUpdating = False
On Error GoTo Cancelled
Set WB = ActiveWorkbook
For Each WS In WB.Worksheets
If WS.Name <> "SearchWord" Then
'Search whole sheet
'With WB.Sheets(WS.Name).Cells
'***********************************
'Alternative to search single column
With WB.Sheets(WS.Name).Range("B:B")
'***********************************
Set Cell = .Find(What:=Search, LookIn:=xlValues, LookAt:=xlPart, _
MatchCase:=False, SearchOrder:=xlByColumns)
If Not Cell Is Nothing Then
FirstAddress = Cell.Address
Do
Counter = Counter + 1
ReDim Preserve FindCell(1 To Counter)
ReDim Preserve FindSheet(1 To Counter)
ReDim Preserve FindWorkBook(1 To Counter)
ReDim Preserve FindPath(1 To Counter)
ReDim Preserve FindText(1 To Counter)
FindCell(Counter) = Cell.Address(False, False)
FindText(Counter) = Cell.Text
FindSheet(Counter) = WS.Name
FindWorkBook(Counter) = WB.Name
FindPath(Counter) = WB.FullName
Set Cell = .FindNext(Cell)
Loop While Not Cell Is Nothing And Cell.Address <> FirstAddress
End If
End With
End If
Next
'If no result found, reset properties and exit sub
If Counter = 0 Then
MsgBox Search & " was not found.", vbInformation, "Zero Results For Search"
'Clear old results if required
'Range("A3", ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell)).ClearContents
'**********************************
GoTo Cancelled
End If
'Add SearchWord sheet if not present
On Error Resume Next
Sheets("SearchWord").Select
If Err <> 0 Then
ThisWorkbook.Sheets("SearchWord").Copy Before:=ActiveWorkbook.Worksheets(1)
End If
On Error GoTo Cancelled
'Clear old data and then format results page as required
Range("A3", ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell)).ClearContents
Range("A1:B1").Interior.ColorIndex = 6
Range("A1").Value = "Occurences of:"
If Reset = True Then Range("B1").Value = Search
Range("A1:D2").Font.Bold = True
Range("A2").Value = "Location"
Range("B2").Value = "Cell Text"
Range("A1:B1").HorizontalAlignment = xlLeft
Range("A2:B2").HorizontalAlignment = xlCenter
With Columns("A:A")
.ColumnWidth = 14
.VerticalAlignment = xlTop
End With
With Columns("B:B")
.ColumnWidth = 50
.VerticalAlignment = xlCenter
.WrapText = True
End With
'Add hyperlinks and results to spreadsheet
For Counter = 1 To UBound(FindCell)
ActiveSheet.Hyperlinks.Add Anchor:=Range("A" & Counter + 2), _
Address:="", SubAddress:="'" & FindSheet(Counter) & "'" & "!" & FindCell(Counter), _
TextToDisplay:=FindSheet(Counter) & " - " & FindCell(Counter)
Range("B" & Counter + 2).Value = FindText(Counter)
'Add text from offset columns; probably not
'appropriate with whole sheet search
Range("C" & Counter + 2).Value = _
Sheets(FindSheet(Counter)).Range(FindCell(Counter)).Offset(0, 1)
Range("D" & Counter + 2).Value = _
Sheets(FindSheet(Counter)).Range(FindCell(Counter)).Offset(0, 2)
'*********************************************
Next Counter
'Find search term and colour text
ColourText
Cancelled:
Set WB = Nothing
Set WS = Nothing
Set Cell = Nothing
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
Sub ColourText()
Dim Strt As Long, x As Long, i As Long
Columns("B:B").Characters.Font.ColorIndex = xlAutomatic
For i = 3 To Range("B" & Rows.Count).End(xlUp).Row
x = 1
Do
Strt = InStr(x, Range("B" & i), [B1], 1)
If Strt = 0 Then Exit Do
Range("B" & i).Characters(Start:=Strt, _
Length:=Len([B1])).Font.ColorIndex = 7
x = Strt + 1
Loop
Next
End Sub
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = "$B$1" Then
Application.Run "SearchWord.xla!FindAll", Target.Text, "False"
Cells(1, 2).Select
End If
End Sub
Option Explicit
Private Sub Workbook_AddinInstall()
On Error Resume Next
Application.CommandBars("Tools").Controls("Search &word").Delete
On Error GoTo 0
With Application.CommandBars("Tools").Controls.Add
.Caption = "Search &word"
.Tag = "Search word"
.OnAction = "'" & ThisWorkbook.Name & "'!Search.DoFindAll"
End With
MsgBox "'Search word' option added to Tools menu"
End Sub
Private Sub Workbook_AddinUninstall()
On Error Resume Next
Application.CommandBars("Tools").Controls("Search &word").Delete
End Sub(CombineFile)
Code:
Option Explicit
'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
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
Function GetDirectory(Optional msg) As String
On Error Resume Next
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 = "Please select the folder of the excel files to copy."
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 CombineFiles()
Dim path As String
Dim FileName As String
Dim LastCell As Range
Dim Wkb As Workbook
Dim WS As Worksheet
Dim ThisWB As String
ThisWB = ThisWorkbook.Name
Application.EnableEvents = False
Application.ScreenUpdating = False
path = GetDirectory
FileName = Dir(path & "\*.xls", vbNormal)
Do Until FileName = ""
If FileName <> ThisWB Then
Set Wkb = Workbooks.Open(FileName:=path & "\" & FileName)
For Each WS In Wkb.Worksheets
Set LastCell = WS.Cells.SpecialCells(xlCellTypeLastCell)
If LastCell.Value = "" And LastCell.Address = Range("$A$1").Address Then
Else
WS.Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
End If
Next WS
Wkb.Close False
End If
FileName = Dir()
Loop
Application.EnableEvents = True
Application.ScreenUpdating = True
Set Wkb = Nothing
Set LastCell = Nothing
End Sub
'Entry point for RibbonX button click
Sub ShowATPDialog(control As IRibbonControl)
Application.Run ("fDialog")
End Sub
'Callback for RibbonX button label
Sub GetATPLabel(control As IRibbonControl, ByRef label)
label = ThisWorkbook.Sheets("RES").Range("A10").Value
End Sub
