-
Notifications
You must be signed in to change notification settings - Fork 5
/
ExcelHelpers.vb
376 lines (289 loc) · 9.67 KB
/
ExcelHelpers.vb
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
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
'
' Depends on ../Common/Collection.vb
'
' V0.11
'
option explicit
type xlsPerfOptions ' {
'
' This type is used in combination with
' xlsStartFillSheet and xlsEndFillSheet
'
' https://vbacompiler.com/optimize-vba-code/
'
calculation_ as xlCalculation
screenUpdating_ as boolean
enableEvents_ as boolean
end type ' }
function findWorksheet(name as string, optional deleteIfExists as boolean = false, optional wb as workbook = nothing) as excel.worksheet ' {
'
' TODO: https://renenyffenegger.ch/notes/Microsoft/Office/Excel/Object-Model/Worksheet/index -> getWorksheet.bas
'
' Return worksheet with the given name.
' If it doesn't exist, it is created.
'
' Optionally, deleteIfExists can be set to true to delete an existing worksheet
' of the given name prior to creating it
'
if wb is nothing then
'
' 2021-06-04: it seems safer to use thisWorkbook rather than activeWorkbook
'
set wb = thisWorkbook
end if
if deleteIfExists then ' {
deleteWorksheet name, wb
end if ' }
on error goto createWorksheet
set findWorksheet = thisWorkbook.sheets(name)
' No error: Worksheet exists. We can return
exit function
createWorksheet:
' Error encountered, probably because the worksheet didn't exist.
' We have to create the worksheet
set findWorksheet = thisWorkbook.sheets.add(after := thisWorkbook.sheets(thisWorkbook.sheets.count))
findWorksheet.name = name
end function ' }
sub deleteWorksheet(name_ as string, optional wb as workbook = nothing) ' {
if wb is nothing then
set wb = thisWorkbook
end if
dim ws as worksheet
set ws = collObjectOrNothing(wb.sheets, name_)
if not ws is nothing then ' {
'
' Set displayAlerts temporarily to false so that the unwanted message
' Microsoft Excel will permanentely delete this sheet. Do you want to continue?
' does not pop up.
'
' Compare with another solution on https://stackoverflow.com/a/31475530/180275
'
' 2021-07-19: Trying to delete very(?) hidden sheets seems not possible
' unless sheet is made visible:
ws.visible = xlSheetVisible
dim da as boolean : da = application.displayAlerts
application.displayAlerts = false
ws.delete
application.displayAlerts = da
end if ' }
end sub ' }
sub deleteRange(name_ as string, optional ws as worksheet = nothing) ' {
if ws is nothing then
set ws = activeWorkbook.activeSheet
end if
on error goto err_
dim rng as range
set rng = ws.range(name_)
on error goto 0
rng.clearFormats
rng.clearContents
ws.parent.names(name_).delete
exit sub
err_:
if err.number <> 1004 then ' 1004 = Application-defined or object-defined error
msgBox "deleteRange: " & err.number & chr(10) & err.description
end if
end sub ' }
sub freezeHeader(ws as excel.workSheet, optional bottomRow as long = 1, optional leftColumn as long = 0) ' {
'
' TODO: https://stackoverflow.com/a/19362973/180275 seems to indicate that
' this sub should make sure that screenUpdating is set to true when the sheet
' is frozen
'
' 2021-07-01: Make sure the currently active sheet and range is activated again when the sub
' is left
'
dim curSheet as worksheet : set curSheet = activeSheet
ws.activate
dim curSelection as range : set curSelection = selection
if leftColumn = 0 then
ws.rows(bottomRow + 1).select
else
ws.cells(bottomRow+1, leftColumn+1).select
end if
with activeWindow
if .freezePanes then .freezePanes = false
' .splitColumn = 0
' .splitRow = bottomRow
.freezePanes = true
end with
curSelection.select
curSheet.activate
end sub ' }
sub insertHyperlinkToVBAMacro(where as range, byVal text as string, byVal macroname as string, paramArray args()) ' {
dim formula as string
formula = "=hyperlink("
formula = formula & """#" & macroname & "("
dim firstArgument as boolean : firstArgument = true
dim argNo as long
for argNo = lBound(args) to uBound(args) ' {
if firstArgument then
firstArgument = false
else
formula = formula & application.international(xlListSeparator) ' semicolon or comma
end if
if varType(args(argNo)) = vbString then
formula = formula & """""" & args(argNo) & """"""
else
formula = formula & args(argNo)
end if
next argNo ' }
formula = formula & ")"""
formula = formula & "," ' Always comma, no need to invoke application.international(xlListSeparator)
formula = formula & """" & text & """"
formula = formula & ")"
where.formula = formula
end sub ' }
function colLetterToNum(colLetter as string) as long ' {
'
' http://vba4excel.blogspot.ch/2012/12/column-number-to-letter-and-reverse.html
'
colLetterToNum = activeWorkbook.worksheets(1).columns(colLetter).column
end function ' }
function colNumToLetter(colNum as long) as string
'
' http://vba4excel.blogspot.ch/2012/12/column-number-to-letter-and-reverse.html
'
colNumToLetter = vba.split(cells(1, colNum).address, "$")(1)
end function ' }
function createButton(rng as range, txt as string, nameSub as string) as button ' {
set createButton = rng.parent.buttons.add( left := rng.left, top := rng.top, width := rng.width, height := rng.height)
createButton.caption = txt
createButton.onAction = nameSub
end function ' }
function unprotect(byVal sh as worksheet, byVal pw as string) as boolean ' {
on error resume next
sh.unprotect pw
if err.number = 1004 then ' {
'
' Sheet could not be unprotected
'
unprotect = false
exit function
end if ' }
unprotect = true
end function ' }
function pageNumberOfCell(c as range) as long ' {
dim vPageCnt as integer
dim hPageCnt as integer
dim sh as worksheet
set sh = c.parent
if sh.pageSetup.Order = xlDownThenOver then
hPageCnt = sh.hPageBreaks.Count + 1
vPageCnt = 1
else
vPageCnt = sh.vPageBreaks.Count + 1
hPageCnt = 1
end if
pageNumberOfCell = 1
dim vpb as vPageBreak
for each vpb In sh.vPageBreaks
if vpb.Location.Column > c.column then exit for
pageNumberOfCell = pageNumberOfCell + hPageCnt
next vpb
dim hpb as hPageBreak
for each hpb In sh.hPageBreaks
If hpb.Location.row > c.row then exit for
pageNumberOfCell = pageNumberOfCell + vPageCnt
next hpb
end function ' }
function isRibbonShown() as boolean ' {
isRibbonShown = application.commandBars("Ribbon").controls(1).height >= 100
end function ' }
sub showRibbon(visible as boolean) ' {
'
' Note: Hiding the Ribbon in Excel or Word causes the workbook
' or Document to occupy the entire screen.
' Thus, before hiding the Ribbon, the size of
' application.window (.left, .top etc) might be stored and
' applied when the ribbon is shown again.
'
'
#if 0 then
'
' This function was originally intended to be put into a
' general OfficeHelper VBa-module. However, it turned out
' that the differences among Office products are too big
' for such a general approach. Thus, this portion of the
' excluded with a #if 0 then preprocessor block.
'
if application.name = "Microsoft Visio" then
'
' Visio does not seem to have .executeMso "HideRibbon" capability, so it
' does not make sense to continue here.
'
end if
if application.name = "Microsoft Access" then ' {
if visible then doCmd.showToolbar "Ribbon", acToolbarYes _
else doCmd.showToolbar "Ribbon", acToolbarNo
exit sub
end if ' }
#end if
if isRibbonShown = visible then
'
' Ribbon already shown/hidden, nothing to be done
'
exit sub
end if
'
' Toggle Ribbon when shown
'
dim fs as boolean
fs = application.displayFullScreen
application.commandBars.executeMso "HideRibbon"
application.displayFullScreen = fs
end sub ' }
sub resetExcelSheet(sh as worksheet) ' {
'
' TODO: This function should probably make sure that sh is not protected when called
'
sh.columns.useStandardWidth = true
sh.rows.useStandardHeight = true
#if 1 then
'
' Drawing a border apparently does not extend
' the size of usedRange. Thus, all cells
' are cleared and the previous sh.usedRange.clear
' left as a reminder
'
sh.cells.clear
#else
sh.usedRange.clear
#end if
dim shp as shape
for each shp in sh.shapes ' {
shp.delete
next shp ' }
dim n as name
for each n in sh.names ' {
n.delete
next n ' }
sh.scrollArea = ""
'
' It seems that a hidden sheet cannot be moved by selecting
' a cell on it (well, it sort of makes sense, though).
'
dim curSheet as worksheet
set curSheet = activeSheet
curSheet.visible = xlSheetVisible
sh.activate
sh.cells(1,1).select
activeWindow.splitRow = 0
activeWindow.splitColumn = 0
activeWindow.split = false
activeWindow.freezePanes = false
curSheet.activate
end sub ' }
public function xlsStartFillSheet as xlsPerfOptions
xlsStartFillSheet.calculation_ = application.calculation
xlsStartFillSheet.screenUpdating_ = application.screenUpdating
xlsStartFillSheet.enableEvents_ = application.enableEvents
application.calculation = xlCalculationManual
application.screenUpdating = false
application.enableEvents = false
end function ' }
public sub xlsEndFillSheet(opt as xlsPerfOptions) ' {
application.calculation = opt.calculation_
application.screenUpdating = opt.screenUpdating_
application.enableEvents = opt.enableEvents_
end sub ' }