S
shiro
Below are my code for searching records in every workbooks in a folder.
The code comes from Ron de Bruin site,and I had been modified it as
I need.And also I have added a progress bar form.The code works
fine so far.It loops through all workbooks in a folder to find the records,
but now I want to create command button'Stop Search' to stop the code
looping/running.I tried enable cancel key but it doesn't work.
Would somebody like to teach me how.
Any help is greatly appreciated.Thank's
Rgds,
Shiro
============================================================
Sub RDB_Filter_Data()
Dim myFiles As Variant
Dim myCountOfFiles As Long
myCountOfFiles = Get_File_Names( _
MyPath:=Worksheets("Record Tracker").Range("A6").Value,
_
Subfolders:=True, _
ExtStr:="*.csv*", _
myReturnedFiles:=myFiles)
If myCountOfFiles = 0 Then
MsgBox "This program can not find any Electrical Data Record " &
vbCrLf _
& "in this folder/subfolder.Try at another location/directory " &
vbCrLf & vbCrLf _
& "Please note:The file's extension you are trying to found " &
vbCrLf _
& "must be Comma Delimited (*.csv)", vbExclamation + vbOKOnly _
, "No files found"
Unload UserForm2
Exit Sub
End If
Get_Filter _
FileNameInA:=True, _
SourceShName:="", _
SourceShIndex:=1, _
FilterRng:="A13:ER" & Rows.Count, _
FilterField:=7, _
FilterValue:="OK", _
myReturnedFiles:=myFiles
End Sub
----------------------------------------------------------------------------
-----------------
Sub Get_Filter(FileNameInA As Boolean, SourceShName As String, _
SourceShIndex As Integer, FilterRng As String, FilterField As
Integer, _
FilterValue As String, myReturnedFiles As Variant)
Dim SourceRange As Range, destrange As Range
Dim mybook As Workbook, BaseWks As Worksheet
Dim rnum As Long, CalcMode As Long
Dim SourceSh As Variant
Dim rng As Range
Dim RwCount As Long
Dim i As Long
Dim WS As Worksheet
Dim wBook As Workbook
Dim vAction As Integer
Dim PctDone As Single
Dim myFiles As Variant
Dim myCountOfFiles As Long
Dim LastRow As Long
Dim myCell As Range
myCountOfFiles = Get_File_Names( _
MyPath:=Worksheets("Record Tracker").Range("A6").Value,
_
Subfolders:=True, _
ExtStr:="*.csv*", _
myReturnedFiles:=myFiles)
'Define sheet where the filter criteria comes from
Set WS = Sheets("Record Tracker")
'Change ScreenUpdating, Calculation and EnableEvents
With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
.EnableEvents = False
End With
'What action will be taken to the Searc result list.
'It's depen on user need,value 2 for paste as new or
'value 1 to concatenate the existing list.
'But check the existance of template search result.xls first
vAction = Worksheets("Record Tracker").Range("D19").Value
Select Case vAction
Case 1
If Len(Dir("C:\Analysis\Tracked Record\Search Result.xls"))
= 0 Then
Call Create_Search_Result_Template
MsgBox "Finished creating template Search Result " &
vbCrLf _
& "on C:\Analysis\Tracked Record", vbInformation _
+ vbOKOnly, "Template created"
Set BaseWks = Workbooks.Open("C:\Analysis\Tracked
Record\Search Result.xls").Worksheets(1)
BaseWks.name = "Search Result"
Else
Set BaseWks = Workbooks.Open("C:\Analysis\Tracked
Record\Search Result.xls").Worksheets(1)
BaseWks.name = "Search Result"
End If
Case 2
If Len(Dir("C:\Analysis\Tracked Record\Search Result.xls"))
= 0 Then
Call Create_Search_Result_Template
MsgBox "Finished creating template Search Result " &
vbCrLf _
& "on C:\Analysis\Tracked Record", vbInformation _
+ vbOKOnly, "Template created"
Set BaseWks = Workbooks.Open("C:\Analysis\Tracked
Record\Search Result.xls").Worksheets(1)
BaseWks.name = "Search Result"
Else
Set BaseWks = Workbooks.Open("C:\Analysis\Tracked
Record\Search Result.xls").Worksheets(1)
BaseWks.name = "Search Result"
With BaseWks
Set rng = Range(Range("A11"), Range("A11").End(xlDown))
rng.EntireRow.Delete
End With
End If
End Select
'Set start row for the Data
rnum = 1
'Check if we use a named sheet or the index
If SourceShName = "" Then
SourceSh = SourceShIndex
Else
SourceSh = SourceShName
End If
'Loop through all files in the array(myFiles)
For i = LBound(myReturnedFiles) To UBound(myReturnedFiles)
Set mybook = Nothing
On Error Resume Next
Set mybook = Workbooks.Open(myReturnedFiles(i))
On Error GoTo 0
If Not mybook Is Nothing Then
'Set SourceRange and check if it is a valid range
On Error Resume Next
With mybook.Sheets(SourceSh)
Set SourceRange = Application.Intersect(.UsedRange,
..Range(FilterRng))
End With
If Err.Number > 0 Then
Err.Clear
Set SourceRange = Nothing
Else
'if SourceRange use all columns then skip this file
If SourceRange.Columns.Count >= BaseWks.Columns.Count Then
Set SourceRange = Nothing
End If
End If
On Error GoTo 0
If Not SourceRange Is Nothing Then
'Find the last row in BaseWks
rnum = RDB_Last(1, BaseWks.Cells) + 1
With SourceRange.Parent
Set rng = Nothing
'Firstly, remove the AutoFilter
.AutoFilterMode = False
'Filter the range on the FilterField column
If WS.Range("A10").Value = "(All)" Then
SourceRange.AutoFilter Field:=7
Else
SourceRange.AutoFilter Field:=7, _
Criteria1:="=" & WS.Range("A10").Value
End If
If WS.Range("B10").Value = "(All)" Then
SourceRange.AutoFilter Field:=11
Else
SourceRange.AutoFilter Field:=11, _
Criteria1:="=" & WS.Range("B10").Value
End If
If WS.Range("C10").Value = "(All)" Then
SourceRange.AutoFilter Field:=12
Else
SourceRange.AutoFilter Field:=12, _
Criteria1:="=" & WS.Range("C10").Value
End If
SourceRange.AutoFilter Field:=13, _
Criteria1:="=" & WS.Range("D10").Value
SourceRange.AutoFilter Field:=14, _
Criteria1:="=" & WS.Range("E10").Value
With .AutoFilter.Range
'Check if there are results after you use AutoFilter
RwCount = .Columns(1).Cells. _
SpecialCells(xlCellTypeVisible).Cells.Count - 1
If RwCount = 0 Then
'There is no data, only the header
Else
' Set a range without the Header row
Set rng = .Resize(.Rows.Count - 1,
..Columns.Count). _
Offset(1,
0).SpecialCells(xlCellTypeVisible)
If FileNameInA = True Then
'Copy the range and the file name
If rnum + RwCount < BaseWks.Rows.Count Then
BaseWks.Cells(rnum,
"A").Resize(RwCount).Value _
= mybook.Path
rng.Copy BaseWks.Cells(rnum, "B")
End If
Else
'Copy the range
If rnum + RwCount < BaseWks.Rows.Count Then
rng.Copy BaseWks.Cells(rnum, "A")
End If
End If
End If
End With
'Remove the AutoFilter
.AutoFilterMode = False
End With
End If
'Close the workbook without saving
mybook.Close SaveChanges:=False
End If
' Update the percentage completed.
PctDone = i / myCountOfFiles
' Call subroutine that updates the progress bar.
UpdateProgressBar PctDone
'Open the next workbook
Next i
'Set the column width in the new workbook
BaseWks.Columns("A").AutoFit
'Restore ScreenUpdating, Calculation and EnableEvents
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = CalcMode
End With
' The task is finished, so unload the UserForm.
Unload UserForm2
With BaseWks
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
Set rng = .Range("A11:A" & LastRow)
For Each myCell In rng.Cells
.Hyperlinks.Add myCell, _
Address:=myCell.Value, _
TextToDisplay:=myCell.Value
Next myCell
End With
With BaseWks
LastRow = .Cells(.Rows.Count, "B").End(xlUp).Row
Set rng = .Range("B11:B" & LastRow)
End With
MsgBox "Search Complete." & vbCrLf _
& Application.Count(rng) & " record(s) in the bin", vbInformation _
+ vbOKOnly, "Search Complete"
If WS.Range("D19").Value = 1 Then
Windows("Search Result.xls").Activate
ActiveWorkbook.Save
ActiveWindow.Close
Else
End If
handleCancel:
If Err = 18 Then
MsgBox "Action cancelled", vbCritical _
+ vbOKOnly, "Error"
End If
End Sub
----------------------------------------------------------------------------
-
Sub UpdateProgressBar(PctDone As Single)
With UserForm2
' Update the Caption property of the Frame control.
.FrameProgress.Caption = Format(PctDone, "0%")
' Widen the Label control.
.LabelProgress.Width = PctDone * _
(.FrameProgress.Width - 10)
End With
' The DoEvents allows the UserForm to update.
DoEvents
End Sub
The code comes from Ron de Bruin site,and I had been modified it as
I need.And also I have added a progress bar form.The code works
fine so far.It loops through all workbooks in a folder to find the records,
but now I want to create command button'Stop Search' to stop the code
looping/running.I tried enable cancel key but it doesn't work.
Would somebody like to teach me how.
Any help is greatly appreciated.Thank's
Rgds,
Shiro
============================================================
Sub RDB_Filter_Data()
Dim myFiles As Variant
Dim myCountOfFiles As Long
myCountOfFiles = Get_File_Names( _
MyPath:=Worksheets("Record Tracker").Range("A6").Value,
_
Subfolders:=True, _
ExtStr:="*.csv*", _
myReturnedFiles:=myFiles)
If myCountOfFiles = 0 Then
MsgBox "This program can not find any Electrical Data Record " &
vbCrLf _
& "in this folder/subfolder.Try at another location/directory " &
vbCrLf & vbCrLf _
& "Please note:The file's extension you are trying to found " &
vbCrLf _
& "must be Comma Delimited (*.csv)", vbExclamation + vbOKOnly _
, "No files found"
Unload UserForm2
Exit Sub
End If
Get_Filter _
FileNameInA:=True, _
SourceShName:="", _
SourceShIndex:=1, _
FilterRng:="A13:ER" & Rows.Count, _
FilterField:=7, _
FilterValue:="OK", _
myReturnedFiles:=myFiles
End Sub
----------------------------------------------------------------------------
-----------------
Sub Get_Filter(FileNameInA As Boolean, SourceShName As String, _
SourceShIndex As Integer, FilterRng As String, FilterField As
Integer, _
FilterValue As String, myReturnedFiles As Variant)
Dim SourceRange As Range, destrange As Range
Dim mybook As Workbook, BaseWks As Worksheet
Dim rnum As Long, CalcMode As Long
Dim SourceSh As Variant
Dim rng As Range
Dim RwCount As Long
Dim i As Long
Dim WS As Worksheet
Dim wBook As Workbook
Dim vAction As Integer
Dim PctDone As Single
Dim myFiles As Variant
Dim myCountOfFiles As Long
Dim LastRow As Long
Dim myCell As Range
myCountOfFiles = Get_File_Names( _
MyPath:=Worksheets("Record Tracker").Range("A6").Value,
_
Subfolders:=True, _
ExtStr:="*.csv*", _
myReturnedFiles:=myFiles)
'Define sheet where the filter criteria comes from
Set WS = Sheets("Record Tracker")
'Change ScreenUpdating, Calculation and EnableEvents
With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
.EnableEvents = False
End With
'What action will be taken to the Searc result list.
'It's depen on user need,value 2 for paste as new or
'value 1 to concatenate the existing list.
'But check the existance of template search result.xls first
vAction = Worksheets("Record Tracker").Range("D19").Value
Select Case vAction
Case 1
If Len(Dir("C:\Analysis\Tracked Record\Search Result.xls"))
= 0 Then
Call Create_Search_Result_Template
MsgBox "Finished creating template Search Result " &
vbCrLf _
& "on C:\Analysis\Tracked Record", vbInformation _
+ vbOKOnly, "Template created"
Set BaseWks = Workbooks.Open("C:\Analysis\Tracked
Record\Search Result.xls").Worksheets(1)
BaseWks.name = "Search Result"
Else
Set BaseWks = Workbooks.Open("C:\Analysis\Tracked
Record\Search Result.xls").Worksheets(1)
BaseWks.name = "Search Result"
End If
Case 2
If Len(Dir("C:\Analysis\Tracked Record\Search Result.xls"))
= 0 Then
Call Create_Search_Result_Template
MsgBox "Finished creating template Search Result " &
vbCrLf _
& "on C:\Analysis\Tracked Record", vbInformation _
+ vbOKOnly, "Template created"
Set BaseWks = Workbooks.Open("C:\Analysis\Tracked
Record\Search Result.xls").Worksheets(1)
BaseWks.name = "Search Result"
Else
Set BaseWks = Workbooks.Open("C:\Analysis\Tracked
Record\Search Result.xls").Worksheets(1)
BaseWks.name = "Search Result"
With BaseWks
Set rng = Range(Range("A11"), Range("A11").End(xlDown))
rng.EntireRow.Delete
End With
End If
End Select
'Set start row for the Data
rnum = 1
'Check if we use a named sheet or the index
If SourceShName = "" Then
SourceSh = SourceShIndex
Else
SourceSh = SourceShName
End If
'Loop through all files in the array(myFiles)
For i = LBound(myReturnedFiles) To UBound(myReturnedFiles)
Set mybook = Nothing
On Error Resume Next
Set mybook = Workbooks.Open(myReturnedFiles(i))
On Error GoTo 0
If Not mybook Is Nothing Then
'Set SourceRange and check if it is a valid range
On Error Resume Next
With mybook.Sheets(SourceSh)
Set SourceRange = Application.Intersect(.UsedRange,
..Range(FilterRng))
End With
If Err.Number > 0 Then
Err.Clear
Set SourceRange = Nothing
Else
'if SourceRange use all columns then skip this file
If SourceRange.Columns.Count >= BaseWks.Columns.Count Then
Set SourceRange = Nothing
End If
End If
On Error GoTo 0
If Not SourceRange Is Nothing Then
'Find the last row in BaseWks
rnum = RDB_Last(1, BaseWks.Cells) + 1
With SourceRange.Parent
Set rng = Nothing
'Firstly, remove the AutoFilter
.AutoFilterMode = False
'Filter the range on the FilterField column
If WS.Range("A10").Value = "(All)" Then
SourceRange.AutoFilter Field:=7
Else
SourceRange.AutoFilter Field:=7, _
Criteria1:="=" & WS.Range("A10").Value
End If
If WS.Range("B10").Value = "(All)" Then
SourceRange.AutoFilter Field:=11
Else
SourceRange.AutoFilter Field:=11, _
Criteria1:="=" & WS.Range("B10").Value
End If
If WS.Range("C10").Value = "(All)" Then
SourceRange.AutoFilter Field:=12
Else
SourceRange.AutoFilter Field:=12, _
Criteria1:="=" & WS.Range("C10").Value
End If
SourceRange.AutoFilter Field:=13, _
Criteria1:="=" & WS.Range("D10").Value
SourceRange.AutoFilter Field:=14, _
Criteria1:="=" & WS.Range("E10").Value
With .AutoFilter.Range
'Check if there are results after you use AutoFilter
RwCount = .Columns(1).Cells. _
SpecialCells(xlCellTypeVisible).Cells.Count - 1
If RwCount = 0 Then
'There is no data, only the header
Else
' Set a range without the Header row
Set rng = .Resize(.Rows.Count - 1,
..Columns.Count). _
Offset(1,
0).SpecialCells(xlCellTypeVisible)
If FileNameInA = True Then
'Copy the range and the file name
If rnum + RwCount < BaseWks.Rows.Count Then
BaseWks.Cells(rnum,
"A").Resize(RwCount).Value _
= mybook.Path
rng.Copy BaseWks.Cells(rnum, "B")
End If
Else
'Copy the range
If rnum + RwCount < BaseWks.Rows.Count Then
rng.Copy BaseWks.Cells(rnum, "A")
End If
End If
End If
End With
'Remove the AutoFilter
.AutoFilterMode = False
End With
End If
'Close the workbook without saving
mybook.Close SaveChanges:=False
End If
' Update the percentage completed.
PctDone = i / myCountOfFiles
' Call subroutine that updates the progress bar.
UpdateProgressBar PctDone
'Open the next workbook
Next i
'Set the column width in the new workbook
BaseWks.Columns("A").AutoFit
'Restore ScreenUpdating, Calculation and EnableEvents
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = CalcMode
End With
' The task is finished, so unload the UserForm.
Unload UserForm2
With BaseWks
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
Set rng = .Range("A11:A" & LastRow)
For Each myCell In rng.Cells
.Hyperlinks.Add myCell, _
Address:=myCell.Value, _
TextToDisplay:=myCell.Value
Next myCell
End With
With BaseWks
LastRow = .Cells(.Rows.Count, "B").End(xlUp).Row
Set rng = .Range("B11:B" & LastRow)
End With
MsgBox "Search Complete." & vbCrLf _
& Application.Count(rng) & " record(s) in the bin", vbInformation _
+ vbOKOnly, "Search Complete"
If WS.Range("D19").Value = 1 Then
Windows("Search Result.xls").Activate
ActiveWorkbook.Save
ActiveWindow.Close
Else
End If
handleCancel:
If Err = 18 Then
MsgBox "Action cancelled", vbCritical _
+ vbOKOnly, "Error"
End If
End Sub
----------------------------------------------------------------------------
-
Sub UpdateProgressBar(PctDone As Single)
With UserForm2
' Update the Caption property of the Frame control.
.FrameProgress.Caption = Format(PctDone, "0%")
' Widen the Label control.
.LabelProgress.Width = PctDone * _
(.FrameProgress.Width - 10)
End With
' The DoEvents allows the UserForm to update.
DoEvents
End Sub