Read this for full information on these modules
This module is my real timesaver. A bunch of Excel functions that I use all the time and as I can't stand repitition, I've automated and streamlined most of what I do. Too many functions to explain here, but most are simple and self-explanatory. Some are stolen from other resources, but most I've just thrown together myself because the vanilla "solutions" online weren't very n00b-friendly, or I just couldn't understand why someone would write half a solution and not spend an extra 10 minutes coding it properly. I've posted a lot of these on various support functions, so if you see my name around the place with some code attached, you'll probably find my suggested code has found its way here, after a bit of tweaking.
Note that this uses Chip Pearson's modKeyState module.
'xlUtils
'v2.19 2014-01-16 13:01
'===========================================================================
' HELP CONTACT
'===========================================================================
' Code is provided without warranty and can be stolen and amended as required.
' Tom Parish
' TJP@tomparish.me.uk
' http://baldywrittencod.blogspot.com
' DGF Help Contact: see BPMHelpContact module
'=========================================================================
'===========================================================================
' xlUtils
'===========================================================================
' various MS Excel wizardry
'===========================================================================
' Additional modules required:
'===========================================================================
' modKeyState
'=========================================================================
' VERSION HISTORY
'=========================================================================
'v2.19 2014-01-16 13:01 - xlU_SafeToQuitExcel: option to quit/close automatically
'v2.18 2013-12-10 17:04 - xlU_SafeToQuitExcel: bugfix in numbers where PERSONAL.XLSB is not open
' v2.17 xlU_Transfer_Ranges: bugfix
' v2.16 xlU_Ranges_Change_Scope: bugfix when converting to Workbook
' v2.15 added xlU_WorkbookIsReadOnly
' v2.14 added xlU_SafeToQuitExcel
' v2.13 added xlU_Ranges_Change_Scope
' v2.12 added xlU_UpdateLinks
' v2.11 added xlU_Transfer_Ranges
' v2.10 added xlU_Convert_File
' v2.09 added xlU_ValidationList
' v2.08 added xlU_Export_Single_Sheets
' added xlU_Protect_All_Sheets
' v2.07 added xlU_BreakLinks
' v2.06 xlU_Ranges_Set_To_Column_1_Data_Rows: bugfix (private const)
' v2.05 added xlU_Numeric_To_Text
' xlU_Clean_Special: removes needless _ from end of string
' xlU_Clean_Special: bugfix, VB removes '
' removed xlU_Check_Special (now xlSharePoint.SP_Check_Special)
' added from xlRanges: xlU_Ranges_Add_Named_After_Column_Headers
' added from xlRanges: xlU_Ranges_Set_To_Column_1_Data_Rows
' v2.04 added Private constants
' v2.03b added xlU_Pause_for_Timeout (BETA - doesn't work?)
' v2.02 added xlU_Find_And_Replace_Text
' v2.01 bugfix xlU_Check_Special; annotations changed
' v2.00 option to specify wb/ws in various macros
' improved xlU_Clean_Special code and annotations
' improved xlU_EmptyFolder warning msgbox
' improved xlU_Remove_Spaces warning msgbox
' v1.09 improved xlU_Remove_Spaces
' Capitalised Macro Names
' removed Public from Subs and Functions
' annotations improved
' v1.08 bugfix in xlU_Check_Special
' improved xlU_SheetExists
' v1.07 added xlU_Check_Special
' added xlU_RemoveAllConnections
' improved xlU_removespaces
' v1.06 added xlU_reset_comment_sizes
' v1.05 xlU_cut_multiple_rows_to_new_location
Option Explicit
Private Const cSpc As String = " "
Private Const cFsl As String = "/"
Private Const cBsl As String = "\"
'Private Const cHyp As String = "-"
'Private Const cAst As String = "*"
'Private Const cPrd As String = "."
'Excel <=2003
Private Const xxls As String = ".xls" 'FileFormat:=56, Office 2003 macro enabled workbook
Private Const xxlt As String = ".xlt" 'FileFormat:=??, Office 2003 macro enabled template
Private Const x2k3 As String = " (2003)" 'added to filename during zip upload, i.e. "Report Name (2003).zip"
'Excel >2003
Private Const xxlx As String = ".xlsx" 'FileFormat:=51, Office 2007/10 workbook
Private Const xxlm As String = ".xlsm" 'FileFormat:=52, Office 2007/10 macro enabled workbook
Private Const xxlb As String = ".xlsb" 'FileFormat:=??, Office 2007/10 binary workbook
Private Const xxtm As String = ".xltm" 'FileFormat:=??, Office 2007/10 macro enabled template
'Other
Private Const xcsv As String = ".csv" 'FileFormat:=6, CSV file
Enum xluScopeChangeType
xluWorksheetToWorkbook
xluWorkbookToWorksheet
End Enum
Sub xlU_SelectLotsOfSheets(ByVal str As String, Optional ByRef wb As Workbook)
'v2.00 2013-05-22 11:51
'selects all sheets where ws.Name contains str
'or selects all if str = ""
If wb Is Nothing Then Set wb = ActiveWorkbook
Dim blnASU As Boolean
blnASU = Application.ScreenUpdating
Application.ScreenUpdating = False
Dim blnreplace As Boolean, sh As Worksheet
blnreplace = True
For Each sh In wb.Worksheets
If InStr(1, sh.Name, str) Or str = "" Then
sh.Select blnreplace
blnreplace = False
End If
Next sh
Application.ScreenUpdating = blnASU
End Sub
Sub xlU_ShowAllObjects(Optional ByRef ws As Worksheet)
'v2.00 2013-05-22 11:51
'shows all objects on sheet and sets to Move and Size with cells
'(permits deletion of columns if hidden comments prevent this)
If ws Is Nothing Then Set ws = ActiveSheet
Dim blnASU As Boolean
blnASU = Application.ScreenUpdating
Application.ScreenUpdating = False
Dim s As Shape
On Error Resume Next
For Each s In ws.Shapes
s.Placement = xlMoveAndSize
Next
Application.ScreenUpdating = blnASU
End Sub
Sub xlU_DeleteAllObjects(Optional ByRef ws As Worksheet)
'v2.00 2013-05-22 11:51
If ws Is Nothing Then Set ws = ActiveSheet
Dim blnASU As Boolean
blnASU = Application.ScreenUpdating
Application.ScreenUpdating = False
Dim s As Shape
On Error Resume Next
For Each s In ws.Shapes
s.Delete
Next
Application.ScreenUpdating = blnASU
End Sub
Sub xlU_ShowAllSheets(Optional ByRef wb As Workbook)
'v2.00 2013-05-22 11:51
If wb Is Nothing Then Set wb = ActiveWorkbook
Dim blnASU As Boolean
blnASU = Application.ScreenUpdating
Application.ScreenUpdating = False
Dim s As Byte
For s = 1 To wb.Sheets.Count
wb.Sheets(s).Visible = True
Next s
Application.ScreenUpdating = blnASU
End Sub
Function xlU_Remove_Spaces(Optional ByVal str As String) As String
'v2.00 2013-05-22 12:23
'...from END of string only
'works through Selection range if str not specified
Const pp As String = "WARNING: cannot undo this action"
Const tt As String = "xlU_Remove_Spaces"
If MsgBox(pp, vbOKCancel Or vbCritical, tt) = vbCancel Then Exit Function
Dim bln As Boolean
bln = Application.ScreenUpdating
Application.ScreenUpdating = False
If str <> vbNullString Then
Do Until Not Right(str, 1) = " "
str = Left(str, Len(str) - 1)
Loop
xlU_Remove_Spaces = str
Else
'string not specified, so work on all cells in Selection
Dim r As Range
For Each r In Selection.Cells
Do Until Not Right(r.Value, 1) = " "
r.Value = Left(r.Value, Len(r) - 1)
Loop
Next r
End If
Application.ScreenUpdating = bln
End Function
Sub xlU_Exit_Design_Mode()
'v1.00
'always exits
'!! running any blank macro will also do this?
With Application.CommandBars("Exit Design Mode").Controls(1)
If .State = msoButtonDown Then .Execute
End With
End Sub
Sub xlU_Enter_Design_Mode()
'v1.00
'!! sometimes enters, sometimes toggles?
Application.CommandBars("Exit Design Mode").Controls(1).Execute
'Application.CommandBars.FindControl(ID:=1605).Execute
End Sub
Sub xlU_EmptyFolder(ByVal fdr As String, Optional ByVal AlsoRmDir As Boolean _
, Optional ByVal DoMsgs As Boolean)
'v2.00 2013-05-22 12:22
'delete all files from specified folder [and remove folder]
Const pp As String = "WARNING: cannot undo this action"
Const tt As String = "xlU_EmptyFolder"
If MsgBox(pp, vbOKCancel Or vbCritical, tt) = vbCancel Then Exit Sub
Const cBsl As String = "\"
Const cFsl As String = "/"
Const cSdS As String = "*.*"
Const emsg As String = "xlU_EmptyFolder failed: path not valid, no slashes"
Dim fn As String, sl As String
If InStr(fdr, cBsl) > 0 Then sl = cBsl
If InStr(fdr, cFsl) > 0 Then sl = cFsl
If sl = vbNullString Then
If DoMsgs = True Then MsgBox emsg, vbCritical, tt
Exit Sub
End If
If Right(fdr, 1) <> sl Then fdr = fdr & sl
fn = Dir(fdr & cSdS)
Do While fn <> vbNullString
On Error Resume Next
Kill fdr & fn
On Error GoTo 0
fn = Dir
Loop 'all files in folder
If AlsoRmDir = True Then RmDir fdr
End Sub
Function xlU_Clean_Special(ByVal str As String, Optional ByVal CropLength As Boolean = True _
, Optional ByVal OnlyFilename As Boolean _
, Optional ByVal OnlyVBObjectName As Boolean) As String
'v2.05 2013-07-25 19:31
'removes invalid special characters from path/file/VBObject name string
' CropLength:=True stops message box warnings and autocrops string to 128 chars
' OnlyFilename:=True also removes slashes \ /
' OnlyVBObjectName:=True also removes slashes, spaces, hyphens, commas, periods
'constants (commented if defined below)
'Const scUS As String = "_"
Const VBNameLength = 35
Const SharePointFileNameLength = 128
'consistency checks are done below for the following constants
Const uniMin As Byte = 0 'first universally forbidden character, MUST BE ZERO
Const uniMax As Byte = 13 'last universally forbidden character, number set according to how many forbidden characters
Const slaFSL As Byte = 14 'first slash, always Fsl, AWAYS uniMax+1
Const slaBSL As Byte = 15 'last slash, always Bsl, AWAYS slaFSL+1
Const vboMin As Byte = 16 'first VBA forbidden character, AWAYS slaBSL+1
Const vboMax As Byte = 22 'last VBA forbidden character, number set according to how many forbidden characters
Dim b As Integer, c As Integer, pp As String
Const tt As String = "ERROR in xlU_Clean_Special"
Dim sc(uniMin To vboMax) As String
sc(uniMin) = "~" 'unimin referenced specifically below
sc(uniMin + 1) = Chr(34) 'Chr(34) = " (quotemark)
sc(uniMin + 2) = "#"
sc(uniMin + 3) = "%"
sc(uniMin + 4) = "&"
sc(uniMin + 5) = "*"
sc(uniMin + 6) = ":"
sc(uniMin + 7) = "<"
sc(uniMin + 8) = ">"
sc(uniMin + 9) = "?"
sc(uniMin + 10) = "{"
sc(uniMin + 11) = "|"
sc(uniMin + 12) = "}"
If uniMin + 13 <> uniMax Then 'consistency check
pp = "uniMin + 13 <> uniMax"
MsgBox pp, vbCritical, tt
End
End If
sc(uniMax) = ".."
'slashes for filenames and VB Object names (NOT paths)
sc(slaFSL) = "/"
sc(slaBSL) = "\"
'hyphen & space & comma & period & brackets & apostrophe for VB Object names
sc(vboMin) = "-"
sc(vboMin + 1) = " "
sc(vboMin + 2) = ","
sc(vboMin + 3) = "."
sc(vboMin + 4) = "("
sc(vboMin + 5) = "'"
If vboMin + 6 <> vboMax Then 'consistency check
pp = "vboMin + 6 <> vboMax"
MsgBox pp, vbCritical, tt
End
End If
sc(vboMax) = ")"
'remove special characters from all
For b = uniMin To uniMax
str = Replace(str, sc(b), vbNullString)
Next b
'check filename length (length AFTER the LAST slash max 128 chars)
b = InStr(1, str, sc(slaFSL)) 'look for fwd slash
If b > 0 Then
str = Replace(str, sc(slaBSL), sc(slaFSL)) 'remove all back slashes
Do Until b = 0 'until last slash found
c = b 'c is position of last slash
b = b + 1 'next position
b = InStr(b, str, sc(slaFSL)) 'next position
Loop
Else 'no fwd slashes
b = InStr(1, str, sc(slaBSL)) 'look for back slash
If b > 0 Then
str = Replace(str, sc(slaFSL), sc(slaBSL)) 'remove all fwd slashes
Do Until b = 0 'until last slash found
c = b 'c is position of last slash
b = b + 1 'next position
b = InStr(b, str, sc(slaBSL)) 'next position
Loop
End If
End If
'c is position of last slash, or 0 if no slashes
If Len(str) - c > SharePointFileNameLength Then
If CropLength = True Then
str = Left(str, VBNameLength)
Else
pp = "WARNING: filename > " & SharePointFileNameLength & " chars" & vbLf & vbLf & str
MsgBox pp, vbCritical, tt
End
End If
End If
If OnlyFilename = True Or OnlyVBObjectName = True Then
'swap all slashes for spaces - NOT suitable for paths!
For b = slaFSL To slaBSL
c = InStr(str, sc(b))
Do While c > 0
str = Left(str, c - 1) & Replace(Right(str, Len(str) - c), sc(b), cSpc)
c = InStr(str, sc(b))
Loop
Next b
End If
If OnlyVBObjectName = True Then
'swap hyphens & spaces & periods for underscore in VB object name
Const scUS As String = "_"
For b = slaFSL To vboMax
str = Replace(str, sc(b), scUS)
Next b
'then remove invalid characters from start of string
Dim c1 As String
c1 = Left(str, 1)
Do While c1 = scUS Or c1 = sc(18) Or IsNumeric(c1)
str = Right(str, Len(str) - 1)
c1 = Left(str, 1)
Loop
'remove double underscore
Do While InStr(str, scUS & scUS) > 0
str = Replace(str, scUS & scUS, scUS)
Loop
'check object name length
If Len(str) > VBNameLength Then
If CropLength = True Then
str = Left(str, VBNameLength)
Else
pp = "WARNING: object name > 35 chars"
MsgBox pp, vbCritical, tt
End If
End If
End If
'remove needless underscores from end of string
Do While Right(str, 1) = scUS
str = Left(str, Len(str) - 1)
Loop
xlU_Clean_Special = str
End Function
Function xlU_SheetExists(ByVal wsname As String _
, Optional ByRef wb As Workbook) As Boolean
'v1.08 2013-04-12 15:00
'returns TRUE if the sheet exists in the active (or specified) workbook
If wb Is Nothing Then Set wb = ActiveWorkbook
xlU_SheetExists = False
On Error GoTo NoSuchSheet
If Len(wb.Sheets(wsname).Name) > 0 Then
xlU_SheetExists = True
Exit Function
End If
NoSuchSheet:
End Function
Function xlU_FileFolderExists(ByVal strFullPath As String) As Boolean
'v1.00
'Author : Ken Puls (www.excelguru.ca)
'URL : http://www.excelguru.ca/node/30
'Macro Purpose: Check if a file or folder exists
On Error GoTo Skip
If Not Dir(strFullPath, vbDirectory) = vbNullString Then xlU_FileFolderExists = True
Skip:
On Error GoTo 0
End Function
Function xlU_GetSpecialFolderNames(Optional ByVal DoDebug As Boolean = True)
'v2.00 2013-05-22 12:06
'examples of legacy code only, better to use modSpecialFolders
'DoDebug = True [default] outputs to Immediate window
'DoDebug = False pops up series of MsgBoxes
Dim objFolders As Object
Set objFolders = CreateObject("WScript.Shell").SpecialFolders
Select Case DoDebug
Case True
Debug.Print objFolders("desktop")
Debug.Print objFolders("allusersdesktop")
Debug.Print objFolders("sendto")
Debug.Print objFolders("startmenu")
Debug.Print objFolders("recent")
Debug.Print objFolders("favorites")
Debug.Print objFolders("mydocuments")
Case False
MsgBox objFolders("desktop")
MsgBox objFolders("allusersdesktop")
MsgBox objFolders("sendto")
MsgBox objFolders("startmenu")
MsgBox objFolders("recent")
MsgBox objFolders("favorites")
MsgBox objFolders("mydocuments")
End Select
End Function
Sub xlU_Reset_Comment_Sizes(Optional ByRef ws As Worksheet _
, Optional ByVal CmtHeight As Single _
, Optional ByVal CmtWidth As Single)
'v1.06 2013-03-19 11:18
'resets all comments on ActiveSheet
'NB: superseded by version in Delivery KPI Template v3.13b
If ws Is Nothing Then Set ws = ActiveSheet
Dim c As Comment, ch As Single, cw As Single
If CmtHeight = 0 Then ch = 60 Else ch = CmtHeight
If CmtWidth = 0 Then cw = 100 Else ch = CmtWidth
For Each c In ws.Comments
c.Shape.Height = ch
c.Shape.Width = cw
Next c
End Sub
Sub xlU_Cut_Multiple_Rows_to_New_Location(Optional ByVal DeleteEmptyRows As Boolean _
, Optional ByRef ws As Worksheet)
'v2.00 2013-05-22 13:10
If ws Is Nothing Then Set ws = ActiveSheet
Dim xl As Application
Set xl = Application
Const RangeToCut As String = "temp_range"
MsgBox "Highlight all rows to copy, and then name that range 'temp_range'", vbOKCancel
Dim BlankRow As Integer
BlankRow = CInt(InputBox("Enter a blank row number (normally somewhere below the bottom of the table) where the rows will be pasted"))
If BlankRow = 0 Then BlankRow = ActiveSheet.Columns(1).Rows(ActiveSheet.Rows.Count).End(xlUp).Offset(1)
xl.Calculation = xlCalculationManual
Dim blnASU As Boolean
blnASU = xl.ScreenUpdating
xl.ScreenUpdating = False
Dim rp As Range, rC As Range
On Error GoTo Error_norange
For Each rC In ws.Range(RangeToCut).Rows
On Error GoTo 0
Set rp = ws.Rows(BlankRow)
If rp.Cells(1).Value <> "" Then GoTo Error_notblank
If rC.Cells(1).Value <> "" Then
'ignores blank rows
rp.EntireRow.Insert
rC.EntireRow.Copy
rp.PasteSpecial xlPasteAll
xl.CutCopyMode = False
End If
'clear [and delete] rc row
rC.EntireRow.ClearContents
If DeleteEmptyRows = True Then rC.EntireRow.Delete
Next rC
GoTo DoTheRest
Error_norange:
MsgBox "range name " & RangeToCut & " not found"
GoTo DoTheRest
Error_notblank:
MsgBox "blank row not blank"
GoTo DoTheRest
DoTheRest:
xl.ScreenUpdating = blnASU
xl.Calculation = xlCalculationSemiautomatic
End Sub
Sub xlU_RemoveAllConnections(ByRef wb As Workbook)
'v1.07 2013-04-10 10:32
'removes active connections EXCEPT first connection (necessary for pivot functions)
'source: http://vbcity.com/forums/t/163459.aspx
If wb.Connections.Count > 1 Then
Dim i As Integer
For i = 2 To wb.Connections.Count
wb.Connections.Item(1).Delete
Next i
Else
'MsgBox wb.Connections.Count
End If
End Sub
Sub xlU_RemoveUnusedConnections(ByRef wb As Workbook)
'v1.08b 2013-04-12 14:46
'removes only inactive connections
MsgBox "xlu_RemoveUnusedConnections doesn't work yet, causes big problems, don't run it"
Exit Sub '!!
If wb.Connections.Count > 0 Then
Dim i As Integer
For i = 1 To wb.Connections.Count
With wb.Connections.Item(i)
Debug.Print .Name
.Refresh
'.Delete
End With
Next i
Else
'MsgBox wb.Connections.Count
End If
End Sub
Sub xlU_Find_And_Replace_Text(ByVal OldString As String, ByVal NewString As String _
, Optional ByRef RangeToFindAndReplace As Range)
'v2.02 2013-06-11 13:18
'bypasses sheet protection restrictions on normal text-only f&r
Dim s As String, spre As String, ssuf As String, c As Range, b As Byte
If RangeToFindAndReplace Is Nothing Then Set RangeToFindAndReplace = Selection
For Each c In RangeToFindAndReplace
s = c.Value
b = InStr(s, OldString)
If b > 0 Then
spre = Left(s, b - 1)
ssuf = Mid(s, b + Len(OldString), Len(s))
s = spre & NewString & ssuf
c.Value = s
End If
Next c
End Sub
Function xlU_Pause_for_Timeout(Optional ByVal TimeOutInSecs As Long) As Boolean
'v2.03b 2013-07-10 16:58
'reports False if Shift is held down
'...except it doesn't work!??
Dim t As Long
With Application
For t = 0 To TimeOutInSecs - 1
.StatusBar = "HOLD SHIFT TO BYPASS | updating in " & TimeOutInSecs - t & "..."
.Wait Now() + TimeSerial(0, 0, 1)
If modKeyState.IsShiftKeyDown = True Then
xlU_Pause_for_Timeout = False
.StatusBar = "UPDATE CANCELLED BY USER"
Exit Function
End If
Next t
.StatusBar = False
End With
xlU_Pause_for_Timeout = True
End Function
Sub xlU_Ranges_Set_To_Column_1_Data_Rows()
'v2.06 2013-07-26 16:40
'Adjusts length of all named ranges on query sheets to match length of data table in column 1
'range names to ignore (can be changed here, or more added in code below):
Const ex1 As String = "_FilterDatabase"
Const ex2 As String = "v_"
Application.Calculation = xlCalculationManual
Dim r As Range, nm As Name, n As String, wn As String, rw() As Long, wmax As Byte, c As Long, qt As QueryTable
wmax = ActiveWorkbook.Sheets.Count
'one rw per sheet
ReDim rw(wmax) As Long
For Each nm In ActiveWorkbook.Names
n = nm.Name
wn = Mid(nm, 2, Len(nm))
wn = Left(wn, InStr(wn, "!") - 1)
wn = Replace(wn, "'", "")
For Each qt In ThisWorkbook.Sheets(wn).QueryTables
'count rows in column 1 for this sheet and adjust ranges to cover
c = Sheets(wn).Columns(1).EntireColumn.Cells(Sheets(wn).Rows.Count).End(xlUp).Row
rw(Sheets(wn).Index) = c
If InStr(nm, "REF!") > 0 Then
'range reference error, delete
nm.Delete
ElseIf InStr(nm.Name, ex1) > 0 Then
'query reference, ignore it
ElseIf InStr(nm.Name, ex2) > 0 Then
'validation table, ignore it
ElseIf Range(nm).Rows.Count <> c Then
'range is wrong length
Sheets(wn).Select
'find length of data set from Column 1
Set r = Range(nm).EntireColumn.Rows(rw(Sheets(wn).Index))
Set r = Range(r, r.EntireColumn.Cells(1))
're-add range name
nm.Delete
ActiveWorkbook.Names.Add n, r
End If
Next qt
Next nm
End Sub
Sub xlU_Ranges_Add_Named_After_Column_Headers(Optional ByRef xlU_Worksheet As Worksheet _
, Optional IncludeHeaders As Boolean = True)
'v2.05 2013-07-25 19:29
'Adds range names according to column headers and length of data table in column 1
Dim rHeader As Range, rColumn As Range, r As Long, rName As String
If xlU_Worksheet Is Nothing Then Set xlU_Worksheet = ActiveSheet
With xlU_Worksheet
'count rows in column 1
r = Application.CountA(.Columns(1).EntireColumn)
If .Columns(1).Cells(.Rows.Count).End(xlUp).Row <> r Then
MsgBox "Column 1 must have continuous data otherwise counts fail", vbCritical, "Error in xlU_Add_Ranges_Named_After_Column_Headers"
Exit Sub
End If
Const rOffset As Byte = 1
If IncludeHeaders = False Then r = r - rOffset 'excludes header
For Each rHeader In .Rows(1).Cells
If rHeader.Value = "" And rHeader.Offset(0, 1).Value = "" Then Exit Sub
If IncludeHeaders = False Then
Set rColumn = .Range(rHeader.Cells.Offset(1), rHeader.Cells.Offset(r))
Else
Set rColumn = .Range(rHeader.Cells(1), rHeader.Cells(r))
End If
rName = xlU_Clean_Special(.Name & "_" & rHeader.Value, True, , True)
ThisWorkbook.Names.Add rName, rColumn
Next rHeader
End With
End Sub
Sub xlU_Numeric_To_Text(ByRef xlU_Range As Range)
'v2.05 2013-07-25 19:46
'NB: Excel may convert to numeric before this point, e.g. when entering 07 will convert to 7 and thus '7
Dim s As String, r As Range
Const cApo As String = "'"
For Each r In xlU_Range.Cells
If IsNumeric(r.Value) Then
s = cApo & r.Text
r.Value = s
End If
Next r
End Sub
Function xlU_BreakLinks(ByRef wb As Workbook) As Boolean
'v2.07 2013-07-31 14:06
'reports False if no Links to break or any other error, otherwise True
xlU_BreakLinks = True
On Error GoTo ErrorHandler
Dim lnk As Variant, i As Integer
With wb
lnk = .LinkSources(xlLinkTypeExcelLinks)
On Error GoTo NothingToBreak
For i = 1 To UBound(lnk)
On Error GoTo ErrorHandler
.BreakLink lnk(i), xlLinkTypeExcelLinks
Next i
End With
NothingToBreak:
Exit Function
ErrorHandler:
xlU_BreakLinks = False
On Error GoTo 0
End Function
Sub xlU_Export_Single_Sheets(ByVal OutputPath As String _
, ByVal OutputXLSX As Boolean, ByVal OutputXLS As Boolean, ByVal OutputCSV As Boolean _
, Optional ByVal xlU_Password As String)
'v2.08 2013-07-31 16:16
'saves a copy of each sheet as a separate lookup file (XLSX and/or XLS and/or CSV)
'filename for each file is [ThisWorkbook.Name & " " & Sheet.Name].[xlsx|xls|csv]
Const v7 As Byte = 12
If Val(Application.Version) < v7 Then
MsgBox "Only works in Excel 2007 or later", vbCritical, "xlU_Export_Single_Sheets"
Exit Sub
End If
xlU_Protect_All_Sheets True, xlU_Password
Application.ScreenUpdating = False
Const cDDD As String = "..."
Const cSep As String = " | "
Const cSpc As String = " "
Const cBsl As String = "\"
Const cFsl As String = "/"
Const cURL As String = "http:"
Dim wb As Workbook, fn As String, shn As String, rw As Integer, f As Byte, p As Byte
'original filename
fn = Replace(Replace(ThisWorkbook.Name, ".xlsm", ""), " (master)", "") 'no extension, remove " (master)"
'fix potential path errors
'convert OutputPath to UNC (URL doesn't work) and force connection
OutputPath = Replace(OutputPath, cFsl, cBsl)
OutputPath = Replace(OutputPath, cURL, "")
If Right(OutputPath, 1) <> cBsl Then OutputPath = OutputPath & cBsl
Shell "explorer " & OutputPath, vbHide
Dim aSBorig, aSBbase As String, aSBdft As String
aSBorig = Application.StatusBar
aSBdft = fn
aSBbase = aSBdft & cSep & "Saving separate single-sheet files"
Application.StatusBar = aSBbase
Dim s As Worksheet
For Each s In ThisWorkbook.Sheets
With s
Application.StatusBar = aSBbase & cSep & .Name & cDDD
On Error Resume Next
.Unprotect xlU_Password
On Error GoTo 0
shn = .Name
.Copy 'to new wb
Set wb = ActiveWorkbook
On Error Resume Next
.Protect xlU_Password
On Error GoTo 0
End With
With wb
xlU_BreakLinks wb
With .Sheets(1)
rw = Application.CountA(.Columns(1)) + 1
.Rows(rw & ":" & .Rows.Count).Delete
.Protect xlU_Password
End With
Application.DisplayAlerts = False
If OutputXLSX = True Then .SaveAs FileName:=OutputPath & fn & cSpc & shn & ".xlsx", FileFormat:=51 'Logis Station Groups Logis Air Station Codes.xlsx
If OutputXLS = True Then .SaveAs FileName:=OutputPath & fn & cSpc & shn & ".xls", FileFormat:=56 'Logis Station Groups Logis Air Station Codes.xls
If OutputCSV = True Then .SaveAs FileName:=OutputPath & fn & cSpc & shn & ".csv", FileFormat:=6 'Logis Station Groups Logis Air Station Codes.csv
.Close
Application.DisplayAlerts = True
End With
Set wb = Nothing
Next s
Application.ScreenUpdating = True
Application.StatusBar = aSBorig
xlU_Protect_All_Sheets True, xlU_Password
End Sub
Sub xlU_Protect_All_Sheets(ByVal DoProtect As Boolean, Optional xlU_Password As String)
'v2.08 2013-07-31 15:51
On Error Resume Next
Dim s As Worksheet
For Each s In ThisWorkbook.Sheets
With s
If DoProtect = True Then .Protect xlU_Password Else .Unprotect xlU_Password
End With
Next s
On Error GoTo 0
End Sub
Function xlU_TransferValidationList(ByRef vSource As Range, ByRef vTarget As Range) As Boolean
'v2.09 2013-08-02 13:05
'returns True if transferred OK
'max 1 cell in vTarget and vSource
'could easily be adapted to copy validations across a whole row from a source row
'e.g.:
' With Target.EntireRow
' For i = 1 To .Cells.Count 'NB: this is very inefficient! Limit this to e.g. columns with headers
' xlU_TransferValidationList .Cells(i), Domains.Rows(2).Cells(i)
' Next i
' End With
On Error GoTo ErrorHandler
Dim c As Byte
c = vSource.Cells.Count
If c > 1 Then GoTo ErrorHandler
With vTarget.Validation
On Error Resume Next
.Delete
On Error GoTo ErrorHandler
.Add Type:=vSource.Validation.Type, AlertStyle:=vSource.Validation.AlertStyle, Operator:= _
vSource.Validation.Operator, Formula1:=vSource.Validation.Formula1
.IgnoreBlank = vSource.Validation.IgnoreBlank
.InCellDropdown = vSource.Validation.InCellDropdown
.InputTitle = vSource.Validation.InputTitle
.InputMessage = vSource.Validation.InputMessage
.ErrorTitle = vSource.Validation.ErrorTitle
.ErrorMessage = vSource.Validation.ErrorMessage
.ShowInput = vSource.Validation.ShowInput
.ShowError = vSource.Validation.ShowError
End With
xlU_TransferValidationList = True
ErrorHandler:
End Function
Function xlU_Transfer_Ranges(ByRef srcws As Worksheet, tgtws As Worksheet)
'v2.17 2013-12-03 17:33
'takes all worksheet ranges from src ws and replicates on tgt ws
On Error Resume Next
Dim rng As Range, rn As String, nm As Name
For Each nm In srcws.Names
tgtws.Names.Add Replace(nm.Name, srcws.Name, tgtws.Name), Replace(nm.Value, srcws.Name, tgtws.Name)
Next nm
End Function
Function xlU_Convert_File(ByRef PathFile As String _
, ByVal FileFormat As XlFileFormat, ByVal SourceIsXML As Boolean _
, Optional ByVal DeleteOriginal As Boolean) As Boolean
'v2.10 2013-08-08 14:40
'opens any compatible format file (must be specified if source in XML format)
'saves as chosen output file format
'will output to CSV, XLS, XLSX, XLSM (add more types below if required)
On Error GoTo ErrorHandler
Dim tempPathFile As String, newPathFile As String, x1 As Byte, x2 As Byte
newPathFile = PathFile
x1 = InStr(newPathFile, ".")
x2 = x1
Do While x2 > 0
x1 = x2
x2 = InStr(x2 + 1, newPathFile, ".")
Loop
If x1 > 0 Then newPathFile = Left(newPathFile, x1 - 1) 'removes extension
tempPathFile = newPathFile & ".temp"
If Dir(tempPathFile) <> "" Then Kill tempPathFile 'target already exists
FileCopy PathFile, tempPathFile 'copy to target
If FileFormat = 6 Then
newPathFile = newPathFile & xcsv
ElseIf FileFormat = 56 Then
newPathFile = newPathFile & xxls
ElseIf FileFormat = 51 Then
newPathFile = newPathFile & xxlx
ElseIf FileFormat = 52 Then
newPathFile = newPathFile & xxlm
Else
MsgBox "FileFormat " & FileFormat & " not allowed, but can add to macro code if required", vbCritical, "xlU_Convert_File"
End If
Application.DisplayAlerts = False
If SourceIsXML Then
Workbooks.OpenXML FileName:=tempPathFile, LoadOption:=xlXmlLoadImportToList
Else
Workbooks.Open tempPathFile
End If
ActiveWorkbook.SaveAs newPathFile, FileFormat
ActiveWorkbook.Close False
If DeleteOriginal = True Then Kill PathFile
Kill tempPathFile 'doesn't delete temp file if there's an error
xlU_Convert_File = True
Exit Function
ErrorHandler:
End Function
Function xlU_UpdateLinks(Optional wb As Workbook) As Boolean
'v2.12 2013-08-27 11:36
'source: http://www.thecodecage.com/forumz/microsoft-excel-forum/212417-excel-visual-basic-applications-update-all-external-links.html
On Error GoTo ErrorHandler
xlU_UpdateLinks = True
If wb Is Nothing Then Set wb = ActiveWorkbook
Dim Links As Variant
Dim i As Integer
With wb
Links = .LinkSources(xlExcelLinks)
If Not IsEmpty(Links) Then
For i = 1 To UBound(Links)
.UpdateLink Links(i), xlLinkTypeExcelLinks
Next i
End If
End With
Exit Function
ErrorHandler:
xlU_UpdateLinks = False
End Function
Function xlU_Ranges_Change_Scope(ByVal xluScopeChange As xluScopeChangeType _
, ByVal xluWorksheet As Worksheet, ByVal xluWorkbook As Workbook _
, Optional ByVal xluDeleteOriginal As Boolean = False) As Boolean
'v2.16 2013-12-03 09:59
'changes scope of Range Names from Worksheet to Workbook, or vice versa
'only creates Name in xluWorksheet if Name refers to xluWorksheet, but can easily run for each sheet in turn
On Error Resume Next
Dim nm As Name, newWBname As String
If xluScopeChange = xluWorksheetToWorkbook Then
For Each nm In xluWorksheet.Names
If InStr(nm.Value, "#REF!") = 0 Then
newWBname = Mid(nm.Name, InStr(nm.Name, "!") + 1, Len(nm.Name)) 'v2.16
xluWorkbook.Names.Add newWBname, nm.Value 'v2.16
If xluDeleteOriginal Then nm.Delete
End If
Next nm
ElseIf xluScopeChange = xluWorkbookToWorksheet Then
For Each nm In xluWorkbook.Names
If InStr(nm.Value, xluWorksheet.Name) > 0 And InStr(nm.Value, "#REF!") = 0 Then
xluWorksheet.Names.Add nm.Name, nm.Value
If xluDeleteOriginal Then nm.Delete
End If
Next nm
End If
End Function
Function xlU_SafeToQuitExcel(Optional ByVal QuitIfSafeOtherwiseCloseThisWorkbookWithoutSaving As Boolean) As Boolean
'v2.19 2014-01-16 13:01 - option to quit/close automatically
'v2.18 2013-12-10 17:04 - bugfix in numbers where PERSONAL.XLSB is not open
'v2.14 2013-10-30 12:41
'True if all open Workbooks (including this one but excluding PERSONAL.XLSB) are saved
'False if any workbooks need saving (not safe to quit)
Dim wb As Workbook, t As Integer
t = 0
For Each wb In Workbooks
If UCase(wb.Name) <> "PERSONAL.XLSB" And wb.Saved <> True Then t = t + 1
Next wb
If t <= 1 Then xlU_SafeToQuitExcel = True
If QuitIfSafeOtherwiseCloseThisWorkbookWithoutSaving Then
'NB: if necessary, workbook should be saved prior to running this function
Application.DisplayAlerts = False
If xlU_SafeToQuitExcel Then Application.Quit
ThisWorkbook.Close False
End If
End Function
Function xlU_WorkbookIsReadOnly(Optional wb As Workbook) As Boolean
'v2.15 2013-10-30 16:12
'Workbook.ReadOnly works for local files, but isn't reliable with SharePoint files
If wb Is Nothing Then
Set wb = ActiveWorkbook
Else
wb.Activate
End If
If InStr(1, Application.Caption, "Read-Only") > 1 _
Or InStr(1, ActiveWindow.Caption, "Read-Only") > 1 _
Then xlU_WorkbookIsReadOnly = True
End Function
No comments:
Post a Comment