-
Notifications
You must be signed in to change notification settings - Fork 0
/
source.vba
336 lines (278 loc) · 10 KB
/
source.vba
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
' Global variables
Dim resultCount, resultCell, cellChk, commChk, shapeChk, fileCount, processCount As Integer
Dim statusbarStr As String
Dim searchArr(1 To 10) As Variant
Dim isCaseSensitive As Boolean
' Constant
Const folderCell As String = "C2"
Const excludeCell As String = "C9"
Const headerFirstCell As String = "B2"
Const headerRowCell As String = "B2:F2"
Const headerColCell As String = "B:F"
Const headerNoCell As String = "B2"
Const headerCellCell As String = "C2"
Const headerValueCell As String = "D2"
Const headerSheetCell As String = "E2"
Const headerFileCell As String = "F2"
Const searchStrCol As String = "C"
' Browse button click
Sub browse_Click()
Dim sFolder As String
' Open the select folder prompt
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Select path"
.ButtonName = "Select"
If .Show = -1 Then ' If OK is pressed
sFolder = .SelectedItems(1)
End If
End With
If sFolder <> "" Then
Range(folderCell).value = sFolder
End If
End Sub
' Grep button click
Sub grep_Click()
' Excel optimize
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
Application.FindFormat.Clear
Dim FileSystem As Object
Dim HostFolder As String
fileCount = 0
processCount = 0
resultCount = 0
resultCell = 2
' Check folder exists
If Dir(Range(folderCell).value, vbDirectory) = "" Then
MsgBox ("Path not found")
Exit Sub
End If
' Check search string
If Not InitSearchArray() Then
MsgBox ("Search condition is empty")
Exit Sub
End If
' Get option checkbox value
cellChk = ThisWorkbook.Worksheets(1).Shapes("chkCell").OLEFormat.Object.value
commChk = ThisWorkbook.Worksheets(1).Shapes("chkComment").OLEFormat.Object.value
shapeChk = ThisWorkbook.Worksheets(1).Shapes("chkShape").OLEFormat.Object.value
isCaseSensitive = ThisWorkbook.Worksheets(1).Shapes("chkCase").OLEFormat.Object.value = 1
' Create Result sheet
Call CreateResultSheet
Set FileSystem = CreateObject("Scripting.FileSystemObject")
' Get number of files
CountFiles FileSystem.GetFolder(Range(folderCell).value)
' Loop through folder and subfolder
DoFolder FileSystem.GetFolder(Range(folderCell).value)
If resultCount > 0 Then
MsgBox ("Complete!")
' Hide status bar
Application.statusbar = False
Dim wsr As Worksheet
Set wsr = ThisWorkbook.Sheets(2)
wsr.Select
wsr.Columns(headerColCell).AutoFit
Call AddBorder
' Scroll to first cell
Application.Goto Reference:=Range("A1"), Scroll:=True
Else
MsgBox ("Not found!")
End If
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
' Loop through folder and subfolder
Function DoFolder(Folder)
Dim wb As Workbook
Dim ws As Worksheet
Dim excludeArr
' Get excluded file
excludeArr = Split(Range(excludeCell).value, ",")
Set fso = CreateObject("Scripting.FileSystemObject")
Dim SubFolder
For Each SubFolder In Folder.SubFolders
DoFolder SubFolder
Next
Dim file
For Each file In Folder.Files
' Ignore excluded file
If IsInArray(file.name, excludeArr) Then
GoTo ContinueLoop
End If
' Operate on each file
Dim fileExt As String
fileExt = fso.GetExtensionName(file)
If fileExt = "xlsx" Or fileExt = "xls" Then
' Update status bar
processCount = processCount + 1
statusbarStr = "Process: " & processCount & "/" & fileCount & " " & file.Path
Application.statusbar = statusbarStr
Set wb = Workbooks.Open(file)
For Each ws In ActiveWorkbook.Worksheets
For Each searchString In searchArr
If Not Trim(searchString) = "" Then
statusbarStr = statusbarStr & "."
If cellChk = 1 Then
Application.statusbar = statusbarStr
Call CellSearch(file, ws, searchString)
End If
If commChk = 1 Then
Application.statusbar = statusbarStr
Call CommentSearch(file, ws, searchString)
End If
If shapeChk = 1 Then
Application.statusbar = statusbarStr
Call ShapeSearch(file, ws, searchString)
End If
End If
Next
Next
wb.Close savechanges:=False
End If
ContinueLoop:
Next
End Function
Function InitSearchArray()
For i = 1 To 10
searchArr(i) = Trim(Range("C" & i + 10).value)
Next
Dim IsValid As Boolean
IsValid = False
For i = 1 To 10
If Not Trim(searchArr(i)) = "" Then
IsValid = True
End If
Next
InitSearchArray = IsValid
End Function
Function CountFiles(Folder)
Set fso = CreateObject("Scripting.FileSystemObject")
Dim SubFolder
For Each SubFolder In Folder.SubFolders
CountFiles SubFolder
Next
Dim file
For Each file In Folder.Files
Dim fileExt As String
fileExt = fso.GetExtensionName(file)
If fileExt = "xlsx" Or fileExt = "xls" Then
fileCount = fileCount + 1
End If
Next
End Function
Function CellSearch(file, Worksheet, searchString)
Dim cl As Range
' Find first instance on sheet
Set cl = Worksheet.Cells.Find(What:=searchString, _
After:=Worksheet.Cells(1, 1), _
LookIn:=xlValues, _
LookAt:=xlPart, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=isCaseSensitive, _
SearchFormat:=False)
If Not cl Is Nothing Then
' if found, remember location
FirstFound = cl.Address
' format found cell
Do
resultCell = resultCell + 1
Call WriteResult(resultCell, Replace(cl.Address, "$", ""), cl.value, Worksheet.name, file.Path)
' find next instance
Set cl = Worksheet.Cells.FindNext(After:=cl)
' repeat until back where we started
Loop Until FirstFound = cl.Address
End If
End Function
Function ShapeSearch(file, Worksheet, searchString)
Dim shape As shape
Dim shapeStr As String
For Each shape In Worksheet.Shapes
If Not shape.Type = msoComment Then
On Error Resume Next
shapeStr = shape.TextFrame.Characters.Text
On Error GoTo 0
If Not isCaseSensitive Then
shapeStr = LCase(shapeStr)
searchString = LCase(searchString)
End If
If Not InStr(shapeStr, searchString) = 0 Then
resultCell = resultCell + 1
Call WriteResult(resultCell, ColNumToLetter(shape.TopLeftCell.Column) & shape.TopLeftCell.Row, shapeStr, Worksheet.name, file.Path)
End If
End If
Next
End Function
Function CommentSearch(file, Worksheet, searchString)
Dim comment As comment
Dim commentStr As String
For Each comment In Worksheet.Comments
On Error Resume Next
commentStr = comment.Text
On Error GoTo 0
If Not isCaseSensitive Then
commentStr = LCase(commentStr)
searchString = LCase(searchString)
End If
If Not InStr(commentStr, searchString) = 0 Then
resultCell = resultCell + 1
Call WriteResult(resultCell, ColNumToLetter(comment.shape.TopLeftCell.Column - 1) & comment.shape.TopLeftCell.Row + 1, commentStr, Worksheet.name, file.Path)
End If
Next
End Function
Function WriteResult(loc, resCell, resValue, resSheet, resBook)
resultCount = resultCount + 1
Dim wsr As Worksheet
Set wsr = ThisWorkbook.Sheets(2)
wsr.Activate
wsr.Range("B" & loc).value = resultCount
wsr.Range("C" & loc).value = resCell
wsr.Range("D" & loc).value = resValue
wsr.Range("E" & loc).value = resSheet
ActiveSheet.Hyperlinks.Add Anchor:=Range("F" & loc), Address:="file:///" & resBook, SubAddress:="'" & resSheet & "'" & "!" & resCell, TextToDisplay:=resBook
End Function
Function IsSheetExists()
Dim ws As Worksheet
On Error Resume Next
Set ws = ThisWorkbook.Sheets("Result")
On Error GoTo 0
If Not ws Is Nothing Then IsSheetExists = True
End Function
Function ColNumToLetter(colNum)
ColNumToLetter = Split(Cells(1, colNum).Address, "$")(1)
End Function
Function CreateResultSheet()
If Not IsSheetExists Then
ThisWorkbook.Sheets.Add(After:=Sheets(1)).name = "Result"
End If
Dim wsr As Worksheet
Set wsr = ThisWorkbook.Sheets(2)
wsr.UsedRange.Delete
wsr.Range(headerNoCell).value = "No"
wsr.Range(headerCellCell).value = "Cell"
wsr.Range(headerValueCell).value = "Value"
wsr.Range(headerSheetCell).value = "Sheet"
wsr.Range(headerFileCell).value = "File"
wsr.Range(headerRowCell).Interior.Color = RGB(46, 52, 64)
wsr.Range(headerRowCell).Font.Color = vbWhite
wsr.Range(headerRowCell).Font.Bold = True
ThisWorkbook.Worksheets(1).Select
End Function
Function AddBorder()
Dim wsr As Worksheet
Set wsr = ThisWorkbook.Sheets(2)
Set lastCell = wsr.UsedRange.Cells(wsr.UsedRange.Cells.Count)
' Add result border
With wsr.Range(headerFirstCell, lastCell).Borders
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
' Align result TOP
wsr.Range(headerFirstCell, lastCell).VerticalAlignment = xlTop
End Function
Function IsInArray(stringToBeFound As String, arr As Variant) As Boolean
IsInArray = (UBound(Filter(arr, stringToBeFound)) > -1)
End Function