CodeKeep VBA Feed

Export the notes text of a PowerPoint presentation

Mon, 02 Jan 2012 12:03:04 GMT

Description: This macro will export the notes text from each slide in your presentation to the file you specify.

Link: http://www.codekeep.net/snippets/114446b3-f5be-4811-9630-f7e4c3286204.aspx

Sub ExportNotesText()

    Dim oSlides As Slides
    Dim oSl As Slide
    Dim oSh As Shape
    Dim strNotesText As String
    Dim strFileName As String
    Dim intFileNum As Integer
    Dim lngReturn As Long

    ' Get a filename to store the collected text
    strFileName = InputBox("Enter the full path and name of file to extract notes text to", "Output file?")

    ' did user cancel?
    If strFileName = "" Then
        Exit Sub
    End If

    ' is the path valid?  crude but effective test:  try to create the file.
    intFileNum = FreeFile()
    On Error Resume Next
    Open strFileName For Output As intFileNum
    If Err.Number <> 0 Then     ' we have a problem
        MsgBox "Couldn't create the file: " & strFileName & vbCrLf _
            & "Please try again."
        Exit Sub
    End If
    Close #intFileNum  ' temporarily

    ' Get the notes text
    Set oSlides = ActivePresentation.Slides
    For Each oSl In oSlides
        For Each oSh In oSl.NotesPage.Shapes
        If oSh.PlaceholderFormat.Type = ppPlaceholderBody Then
            If oSh.HasTextFrame Then
                If oSh.TextFrame.HasText Then
                    strNotesText = strNotesText & "Slide: " & CStr(oSl.SlideIndex) & vbCrLf _
                    & oSh.TextFrame.TextRange.Text & vbCrLf & vbCrLf
                End If
            End If
        End If
        Next oSh
    Next oSl

    ' now write the text to file
    Open strFileName For Output As intFileNum
    Print #intFileNum, strNotesText
    Close #intFileNum

    ' show what we've done
    lngReturn = Shell("NOTEPAD.EXE " & strFileName, vbNormalFocus)

End Sub

How to get a list of the slide titles and notes text in PowerPoint?

Mon, 02 Jan 2012 12:01:56 GMT

Description: Paste all of the code below into a new module and run it to get a listing of the slide titles and notes text in your presentation. This version includes the option to output only entries for slides WITH notes or ALL slides.

Link: http://www.codekeep.net/snippets/c9f9875c-aea1-45e5-ae3b-7f4880303b13.aspx

Option Explicit

Dim fOnlyEmptyNotes As Boolean

Sub ExportNotesText()

    Dim oSlides As Slides
    Dim oSl As Slide
    Dim oSh As Shape
    Dim strNotesText As String
    Dim strFileName As String
    Dim intFileNum As Integer
    Dim lngReturn As Long
    Dim results As VbMsgBoxResult
    
    
    ' Get a filename to store the collected text
    strFileName = Replace(ActivePresentation.FullName, ".ppt", ".txt")
    strFileName = InputBox("Enter the full path and name of file to extract notes text to", "Output file?", strFileName)
    strNotesText = "Slide Notes from PowerPoint presentation:" & vbCrLf & _
                    ActivePresentation.FullName & vbCrLf & vbCrLf
    
    ' Include only slides with notes in output file?
    results = MsgBox("Would you like to ONLY include Slides that actually have Notes in your output file?", _
        vbQuestion + vbYesNoCancel, "Output Results")
    If results = vbYes Then
        fOnlyEmptyNotes = True
        strNotesText = strNotesText & _
            "IMPORTANT:  This file contains only the slides that have Notes!" & vbCrLf & vbCrLf
    Else
        fOnlyEmptyNotes = False
    End If
    
    

    ' did user cancel?
    If strFileName = "" Or results = vbCancel Then
        Exit Sub
    End If

    ' is the path valid?  crude but effective test:  try to create the file.
    intFileNum = FreeFile()
    On Error Resume Next
    Open strFileName For Output As intFileNum
    If Err.Number <> 0 Then     ' we have a problem
        MsgBox "Couldn't create the file: " & strFileName & vbCrLf _
            & "Please try again."
        Exit Sub
    End If
    Close #intFileNum  ' temporarily

    ' Get the notes text
    Set oSlides = ActivePresentation.Slides
    
    For Each oSl In oSlides
        If fOnlyEmptyNotes = True Then
            ' Only output notes for slides with actual note text
            If NotesText(oSl) <> vbNullString Then
                strNotesText = strNotesText & "-----------------------------------" & vbCrLf
                strNotesText = strNotesText & "TITLE:  " & SlideTitle(oSl) & vbCrLf
                strNotesText = strNotesText & "NUMBER: " & oSl.SlideNumber & vbCrLf
                strNotesText = strNotesText & "NOTES:  " & NotesText(oSl) & vbCrLf & vbCrLf
            End If
        Else
            ' Output all slides
            strNotesText = strNotesText & "-----------------------------------" & vbCrLf
            strNotesText = strNotesText & "TITLE:  " & SlideTitle(oSl) & vbCrLf
            strNotesText = strNotesText & "NUMBER: " & oSl.SlideNumber & vbCrLf
            strNotesText = strNotesText & "NOTES:  " & NotesText(oSl) & vbCrLf & vbCrLf
        End If
        
    Next oSl

    ' now write the text to file
    Open strFileName For Output As intFileNum
    Print #intFileNum, strNotesText
    Close #intFileNum

    ' show what we've done
    lngReturn = Shell("NOTEPAD.EXE " & strFileName, vbNormalFocus)

End Sub
Function SlideTitle(oSl As Slide) As String
    Dim oSh As Shape
    For Each oSh In oSl.Shapes
        If oSh.Type = msoPlaceholder Then
            If oSh.PlaceholderFormat.Type = ppPlaceholderTitle _
                Or oSh.PlaceholderFormat.Type = ppPlaceholderCenterTitle Then
                If Len(oSh.TextFrame.TextRange.Text) > 0 Then
                    SlideTitle = oSh.TextFrame.TextRange.Text
                Else
                    SlideTitle = "Slide " & CStr(oSl.SlideIndex)
                End If
                Exit Function
            End If
        End If
    Next
End Function

Function NotesText(oSl As Slide) As String
' Only looking for Shape.Type = PlaceHolder which contains notes
    Dim oSh As Shape
    
    For Each oSh In oSl.NotesPage.Shapes
        If oSh.Type = msoPlaceholder Then
            If oSh.PlaceholderFormat.Type = ppPlaceholderBody Then
                If oSh.HasTextFrame Then
                    If oSh.TextFrame.HasText Then
                        NotesText = oSh.TextFrame.TextRange.Text
                    End If
                End If
            Else
                NotesText = vbNullString
            End If
        End If
    Next oSh
    
End Function

Merge text from several text boxes into one text box in Powerpoint

Mon, 02 Jan 2012 11:55:56 GMT

Description: Merge text from several text boxes into one text box in Powerpoint From PPTools.. not mine.. http://www.pptfaq.com/FAQ00787.htm

Link: http://www.codekeep.net/snippets/1e967792-f881-4bf0-af9c-d51250660572.aspx

Sub MergeTextBoxes()

' This will merge the text from all selected text boxes into the
' first selected box then delete the other text boxes

' ** PLEASE NOTE this merges the ext in order selected so be careful
' ** About selecting the text in order

    Dim oRng As ShapeRange
    Dim oFirstShape As Shape
    Dim oSh As Shape
    Dim x As Long

    Set oRng = ActiveWindow.Selection.ShapeRange

        Set oFirstShape = oRng(1)
        oFirstShape.TextFrame.TextRange.Text = _
            oFirstShape.TextFrame.TextRange.Text & vbCrLf

    For x = 2 To oRng.Count
        oFirstShape.TextFrame.TextRange.Text = _
            oFirstShape.TextFrame.TextRange.Text _
            & oRng(x).TextFrame.TextRange.Text

        If x < oRng.Count Then

            oFirstShape.TextFrame.TextRange.Text = _
                oFirstShape.TextFrame.TextRange.Text _
                & vbCrLf

        End If

    Next

    For x = oRng.Count To 2 Step -1
        oRng(x).Delete

    Next

    Set oRng = Nothing
    Set oFirstShape = Nothing
    Set oSh = Nothing

End Sub

Test snipped one here ...

Fri, 13 May 2011 17:03:03 GMT

Description: Test whatever is here

Link: http://www.codekeep.net/snippets/fc8a533b-2ef3-402d-85a7-44aad5a2a2a4.aspx

  Dim rgExp As Range: Set rgExp = Range("B5:H14")
    
    ''rgExp.CopyPicture Appearance:=xlScreen, Format:=xlPicture
    rgExp.CopyPicture Appearance:=xlScreen, Format:=xlBitmap
    
    With ActiveSheet.ChartObjects.Add(Left:=rgExp.Left, Top:=rgExp.Top, _
                                      Width:=rgExp.Width, Height:=rgExp.Height)
        .Name = "ChartVolumeMetricsDevEXPORT"
        ''.Chart.ChartType = xlColumnStacked
        .Activate
    End With
    ''ActiveSheet.ChartObjects("ChartVolumeMetricsDevEXPORT").Activate
    ActiveChart.Paste
    ActiveSheet.ChartObjects("ChartVolumeMetricsDevEXPORT").Activate
    ActiveSheet.ChartObjects("ChartVolumeMetricsDevEXPORT").Chart.Export "C:\testmeExportChart.jpg"
    ActiveSheet.ChartObjects("ChartVolumeMetricsDevEXPORT").Delete

Merge text from several text boxes into one text box in Powerpoint

Mon, 17 Jan 2011 17:24:38 GMT

Sub MergeTextBoxes()

' This will merge the text from all selected text boxes into the
' first selected box then delete the other text boxes

' ** PLEASE NOTE this merges the ext in order selected so be careful
' ** About selecting the text in order

    Dim oRng As ShapeRange
    Dim oFirstShape As Shape
    Dim oSh As Shape
    Dim x As Long

    Set oRng = ActiveWindow.Selection.ShapeRange

        Set oFirstShape = oRng(1)
        oFirstShape.TextFrame.TextRange.Text = _
            oFirstShape.TextFrame.TextRange.Text & vbCrLf

    For x = 2 To oRng.Count
        oFirstShape.TextFrame.TextRange.Text = _
            oFirstShape.TextFrame.TextRange.Text _
            & oRng(x).TextFrame.TextRange.Text

        If x < oRng.Count Then

            oFirstShape.TextFrame.TextRange.Text = _
                oFirstShape.TextFrame.TextRange.Text _
                & vbCrLf

        End If

    Next

    For x = oRng.Count To 2 Step -1
        oRng(x).Delete

    Next

    Set oRng = Nothing
    Set oFirstShape = Nothing
    Set oSh = Nothing

End Sub

Export Active Chart in Excel as PNG

Mon, 17 Jan 2011 17:18:04 GMT

Description: Export Active Chart in Excel as PNG to C:/

Link: http://www.codekeep.net/snippets/51082732-95bf-4d24-9e4f-8f75c05ac815.aspx

Sub Save_ChartAsImage()

Dim oCht As Chart
Set oCht = ActiveChart
On erRROR GoTo Err_Chart

     oCht.Export Filename:="C:\ExcelExport.png", Filtername:="png"

Err_Chart:
If Err <> 0 Then
     Debug.Print Err.Description
Err.Clear
End If

End Sub

DuplicateRecord

Mon, 24 May 2010 15:54:13 GMT

Description: Create a new record in Access that has data identical to a selected record.

Link: http://www.codekeep.net/snippets/3a8226eb-bc6a-4fb5-abb6-aa68216f2e94.aspx

Function DuplicateRecord(tblName As String, AutoGenID As String, AutoGenValue As Integer) As Long

Dim rRst As Recordset
Dim fFld As Field
Dim lFieldCounter As Long
Dim sFind As String

On Error GoTo Error_Handler

Set rRst = CurrentDb.OpenRecordset(tblName, dbOpenDynaset)
sFind = "[" & AutoGenID & "]=" & AutoGenValue

lFieldCounter = 0

With rRst
.FindFirst sFind
ReDim sArrayFieldName(.Fields.Count) As String
ReDim vArrayFieldValue(.Fields.Count) As Variant

For Each fFld In .Fields
    lFieldCounter = lFieldCounter + 1
    sArrayFieldName(lFieldCounter) = fFld.Name
    vArrayFieldValue(lFieldCounter) = Nz(fFld.Value, fFld.DefaultValue)
    If vArrayFieldValue(lFieldCounter) = "" Then vArrayFieldValue(lFieldCounter) = "IGNORETHISVALUE"
    
Next fFld

lFieldCounter = 0
.AddNew
For Each fFld In .Fields
lFieldCounter = lFieldCounter + 1
If .Fields(sArrayFieldName(lFieldCounter)).Name <> AutoGenID Then
If vArrayFieldValue(lFieldCounter) <> "IGNORETHISVALUE" Then _
.Fields(sArrayFieldName(lFieldCounter)) = vArrayFieldValue(lFieldCounter)
End If

Next fFld

.Update
.Bookmark = .LastModified
DuplicateRecord = .Fields(AutoGenID)
End With

ExitFunction:
Exit Function

Error_Handler:

Select Case Err.Number
    Case 3022
        Resume Next
    Case Else
        MsgBox Err.Description & " (" & Err.Number & ")"
End Select

End Function

ChartList v2

Fri, 07 May 2010 15:39:21 GMT

Description: Get complete list of charts, the sheet they are on and their index number on a seperate sheet

Link: http://www.codekeep.net/snippets/a18d2fd8-902e-4a3b-a90f-ccc4bb618db7.aspx

Public Sub chart_list()
Dim oChtobj As ChartObject
Dim oWsht As Worksheet
Dim iRange As Integer
Dim iList As Integer
Dim iCount As Integer

On Error Resume Next

Application.ScreenUpdating = False
iCount = 0
'Create Chart List Sheet (only create if not existent)
For Each oWsht In Sheets
    If oWsht.Name = "FRS Chart List" Then
        Application.DisplayAlerts = False
            oWsht.Delete
        Application.DisplayAlerts = True
    End If
    iCount = iCount + oWsht.ChartObjects.Count
Next oWsht

Sheets.Add.Name = "Chart List (SJM ©)"

ReDim sArraysheet(iCount) As String
ReDim sArraychart(iCount) As String
ReDim sArrayindex(iCount) As String
ReDim sArrayRangeString(iCount) As Integer
ReDim sArrayIsEmpty(iCount) As String

'Collect the chart info
For Each oWsht In Sheets
    If oWsht.Name = "Chart List (SJM ©)" Then GoTo SkipSheet
        For Each oChtobj In oWsht.ChartObjects
            sArraysheet(iList) = oWsht.Name
            sArraychart(iList) = oChtobj.Name
            sArrayindex(iList) = oChtobj.index
            sArrayRangeString(iList) = oChtobj.Chart.SeriesCollection.Count
            If sArrayRangeString(iList) = 0 Then sArrayIsEmpty(iList) = "Yes"
            iList = iList + 1
        Next oChtobj
SkipSheet:
Next oWsht

'Write to the new Sheet
Worksheets("Chart List (SJM ©)").Activate

With Range("A1")
.Value = "List of Chart Objects in this Workbook"
.Font.Bold = True
.ColumnWidth = 35
End With

With Range("A2")
.Value = "Sheet Name"
.Font.Color = vbRed
End With

With Range("B1")
.Value = "Total Charts: " & iCount
.ColumnWidth = 15
End With

With Range("B2")
.Value = "Chart Name"
.Font.Color = vbRed
End With

With Range("C2")
.ColumnWidth = 11
.Value = "Chart Index"
.Font.Color = vbRed
End With

With Range("D2")
.Value = "Empty Chart?"
.Font.Color = vbRed
.ColumnWidth = 17
End With

iRange = 3

For iList = LBound(sArraysheet) To UBound(sArraysheet)
    Cells(iRange, 1).Value = sArraysheet(iList)
    Cells(iRange, 2).Value = sArraychart(iList)
    Cells(iRange, 3).Value = sArrayindex(iList)
    Cells(iRange, 4).Value = sArrayIsEmpty(iList)
    iRange = iRange + 1
Next iList


Range("A3:D9999").Select
    Selection.Sort Key1:=Range("B2"), Order1:=xlAscending, Header:=xlGuess, _
    OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
    DataOption1:=xlSortNormal
    
Cells(3, 1).Select
ActiveWindow.FreezePanes = True

Application.ScreenUpdating = True

End Sub

Turning Alerts off on screen

Thu, 06 May 2010 09:03:31 GMT

Description: Title says it all

Link: http://www.codekeep.net/snippets/b959df05-e3e0-4b03-8617-5b9d8d2bf93a.aspx

            Application.DisplayAlerts = False

Screen Select

Thu, 06 May 2010 09:02:45 GMT

Description: Selecting all that is shown on the screen , plus some tweaks

Link: http://www.codekeep.net/snippets/d014f305-c822-421e-83c7-9124dbeafd8f.aspx

This can be used in excel to select all that is there on screen 


Activesheet.usedrange.select

Modified code about this , that is letting go of the header & then deleteting them , to select instead of rows.delete write select

 
Application.DisplayAlerts = false ' as it would ask you whether you wanna delete
ActiveSheet.UsedRange.Offset(1, 0).Resize(ActiveSheet.UsedRange.Rows.Count - 1).Rows.Delete
            Application.DisplayAlerts = True

Create charts

Tue, 04 May 2010 08:10:12 GMT

Description: Charting values from particular sheets

Link: http://www.codekeep.net/snippets/c6c824f2-0398-4b1e-8d0a-10069ec74917.aspx

Sub CreateChart()
Dim ChartObj As ChartObject
Dim ChartSeries As Series, chartseries2 As Series, c3 As Series, c4 As Series, c5 As Series, c6 As Series, c7 As Series



For I = 3 To 10 ' dis allows me to run the loop however I want 


Sheets(I).Select 

'Deleteing older charts ,if you had like
'On Error Resume Next
'ActiveSheet.ChartObjects("PRASHANT").Delete




Set ChartObj = ActiveSheet.ChartObjects.Add(Left:=100, Width:=550, Top:=75, Height:=325)

Set ChartSeries = ChartObj.Chart.SeriesCollection.NewSeries
ChartObj.Chart.ChartType = 4
ChartObj.Name = "PRASHANT"


With ChartSeries
            .Name = "UB"
            .Values = ActiveSheet.Range("i3:i393")
 End With
 
 Set chartseries2 = ChartObj.Chart.SeriesCollection.NewSeries

 With chartseries2
            .Name = "LB1"
            .Values = ActiveSheet.Range("h3:h393")
            
 End With
 
 
Set c3 = ChartObj.Chart.SeriesCollection.NewSeries
With c3
    .Name = "UB1"
    .Values = ActiveSheet.Range("j3:j393")
    
End With



Next

End Sub

Copying ranges from 1 sheet to another

Tue, 04 May 2010 08:05:02 GMT

Description: No macro

Link: http://www.codekeep.net/snippets/21dcef17-6acb-40ee-8756-6906ac4e4d45.aspx


range("a2:j2").value = sheets("abc").range("__").value

Offset can be integrated


I can use the formula as well by substituting value with formula that works fine as well.

ReturnTabName

Wed, 28 Apr 2010 11:22:23 GMT

Description: Retrieve the current tab name in the Pages collection (Microsoft Access)

Link: http://www.codekeep.net/snippets/223b666a-7915-4ad4-81e4-879c4968e006.aspx

Function ReturnTabName(frm As Form, TabControlName As String) As String
ReturnTabName = frm(TabControlName).Pages(frm(TabControlName)).Name
End Function

Copying a Column value Smarter way

Thu, 22 Apr 2010 12:07:30 GMT

Description: Using vba to copy and paste ranges & Columns

Link: http://www.codekeep.net/snippets/39ab9455-57cb-4bbb-bb94-9f28924fb2c7.aspx

Sheets("V9").Columns("A:D").Value = Sheets("RawData").Columns("F:I").Value
 

See the smart part , it's opposite of the copy command which requires me type 
the source before and don't give me values

Dynamic Array Size & Transpose

Thu, 22 Apr 2010 11:49:02 GMT

Description: Dynamic Array - Redefining it's size with redim and transposing it

Link: http://www.codekeep.net/snippets/42fc8c6a-43c5-47a0-a1b3-54714724ce48.aspx

Sub opportunity()
Dim opp() As Integer
Dim trades As Integer ' we define the trades we can take on basis of fv
Dim i As Integer


trades = 0

lastrow = Range("x2").End(xlDown).Row 

upbounx = 1 

ReDim opp(1 To lastrow)

For i = 1 To lastrow

opp(i) = Range("x1").Offset(i, 0) - upbound

Next

Range("aa2:aa" & lastrow) = WorksheetFunction.Transpose(opp)

End Sub

Excel Transpose

Thu, 22 Apr 2010 11:46:24 GMT

Description: How to print your Array your created

Link: http://www.codekeep.net/snippets/1f026b9e-a550-4d6e-aa59-be350f1608f2.aspx

Range("aa2:aa20") = WorksheetFunction.Transpose(opp)


Here opp() is my array of 20 objects

To make it little bit dynamic I can define last row variable by 

lastrow = a2.end(xldown).row

Excel Autofill

Thu, 22 Apr 2010 09:50:46 GMT

Description: Autofill by & Numberformat

Link: http://www.codekeep.net/snippets/a40368dc-d57c-4564-b4ca-e34f5dc184f3.aspx

Range("a5").Copy Range("e5")

Range("e5").AutoFill Range("e5:e" & lrow), xlFillDefault
Columns("E:E").NumberFormat = "DDDD" ' dis converts the number format to days


Also a good thing to see here is that in part II , e5 is going to be used,
as we can only drag that part ddown 


Range("e5:i5").autofill range("e5:i233") , this will autofill till i233



Other Options

   xlFillDefault = 0 
   xlFillCopy = 1 
   xlFillSeries = 2 
   xlFillFormats = 3 
   xlFillValues = 4 
   xlFillDays = 5 
   xlFillWeekdays = 6 
   xlFillMonths = 7 
   xlFillYears = 8 
   xlLinearTrend = 9 
   xlGrowthTrend = 10

Excel

Thu, 22 Apr 2010 09:48:33 GMT

Description: Going to the last row

Link: http://www.codekeep.net/snippets/e51ba2b6-f4ec-4c0f-a0ee-2a88167a7532.aspx

Dim lrow As Long

lrow = Cells(Rows.Count, 2).End(xlUp).Row

FormatAddress

Tue, 20 Apr 2010 11:44:41 GMT

Description: Turn an address string into a properly formatted address block

Link: http://www.codekeep.net/snippets/ef5258c4-d40b-462b-aa27-6e75ed88fc49.aspx

Function FormatAddress(AddressIn As String, _
DelimiterUsed As String) As String

Dim sAddress As String
Dim i As Integer
sAddress = AddressIn

While InStr(1, sAddress, DelimiterUsed & Space(1)) > 0 Or InStr(1, sAddress, Space(1) & DelimiterUsed) > 0
    sAddress = Replace(sAddress, DelimiterUsed & Space(1), DelimiterUsed)
    sAddress = Replace(sAddress, Space(1) & DelimiterUsed, DelimiterUsed)
Wend


FormatAddress = Replace(sAddress, DelimiterUsed, vbNewLine)

End Function

HighlightRecord

Fri, 16 Apr 2010 13:19:41 GMT

Description: Highlight a record in Microsoft Access

Link: http://www.codekeep.net/snippets/7d83787e-1be0-4cf9-87ec-2b72f350e403.aspx

Function HighlightRecord(frm As Form, ctl As Control)
Dim sName As String
sName = ctl.Name

frm.TextHighlight.ControlSource = _
"=iif([" & sName & "]='" & ctl.Value & "','Yes','No')"

End Function

LastnMax

Thu, 15 Apr 2010 11:57:01 GMT

Description: Excel VBA to retrieve a maximum value from previous rows. Can be used to return the value within VBA or as a UDF

Link: http://www.codekeep.net/snippets/565cebd9-d5dd-477e-8dd2-d521d2ca6002.aspx

Function LastnMax(sWorkSheet As String, sColumn As String, RowsToOffset) As Variant

Application.Volatile True

Dim rLastRow As Integer
'Find the last used row in the chosen sheet and column (actual)
rLastRow = Worksheets(sWorkSheet).Range(sColumn & Worksheets(sWorkSheet).Rows.Count).End(xlUp).Row

With Worksheets(sWorkSheet)
'If there is a function to cause the cell contents to be blank loop upwards, past these
While .Cells(rLastRow, sColumn).Value = "" Or .Cells(rLastRow, sColumn).Value = 0
    rLastRow = .Cells(rLastRow, sColumn).Offset(-1, 0).Row
Wend

'Finally, work out the maximum value in a range count of <n>(last <n> entries in other words)
    LastnMax = WorksheetFunction.Max(.Range( _
    .Cells(rLastRow, sColumn).Offset(-RowsToOffSet, 0).Address, _
    .Cells(rLastRow, sColumn).Address))
    
End With

End Function

Arg_Section

Thu, 15 Apr 2010 11:36:46 GMT

Description: Retrieves a single string value from a long string with uniform delimiters based on a section number in the codes argument.

Link: http://www.codekeep.net/snippets/6c3485e4-400a-4f60-8340-1e534957b02d.aspx

Function Arg_Section(WholeString As String, SectionNumber As Integer, _
DelimiterChar As String) As String
' Steve Moore
' 24/04/04
' Returns a string from a given section (index)within a larger delimited string
' Usage: varString=Arg_Section(Delimited String, Required Section Number FROM String, Delimiter)
'

On Error Resume Next

Dim IntSectionStart As Integer
Dim IntSectionEnd As Integer
Dim DblStringLength As Double
Dim i As Integer
Dim IntDelim1Loc As Integer
Dim IntDelim2Loc As Integer
Dim IntDelimLocation As Integer
Dim IntStringLoc As Integer
Dim pWholeString As String
pWholeString = WholeString
pWholeString = DelimiterChar & pWholeString & DelimiterChar

DblStringLength = Len(pWholeString) 'Find the length of the passed, delimited string
IntDelim1Loc = SectionNumber - 1 'Number of leading delimiter
IntDelim2Loc = SectionNumber 'Number of trailing delimiter
IntDelimLocation = IntDelim1Loc 'Store 1st position number to general variable

Examine_Delim:
IntStringLoc = 1 'Beginning location in string

For i = 0 To IntDelimLocation

IntStringLoc = InStr(IntStringLoc, pWholeString, DelimiterChar)
IntStringLoc = IntStringLoc + 1

Next i

If IntDelimLocation = IntDelim1Loc Then
    IntSectionStart = IntStringLoc
    IntDelimLocation = IntDelim2Loc
    GoTo Examine_Delim
End If

If IntDelimLocation = IntDelim2Loc Then
    IntSectionEnd = IntStringLoc - 1
End If

Arg_Section = Mid(pWholeString, IntSectionStart, (IntSectionEnd - IntSectionStart))

End Function

ShuffleUp

Thu, 15 Apr 2010 11:21:55 GMT

Description: Tabbed form with various control on each form. Where varying amounts of these controls will be programmatically hidden 'Shuffleup' goes through each tab and moves all controls up so that they are nicely positioned.

Link: http://www.codekeep.net/snippets/e0c0a71f-6c8f-4897-b303-2f272fc4bd53.aspx

Function ShuffleUp(frm As Form)
On Error Resume Next
Dim ctl As Control
Dim ipos As Integer
Dim pg As Control
Dim bShift As Boolean
For Each pg In frm.Controls
        If pg.ControlType = acPage Then
        bShift = False
            For Each ctl In frm.Controls
                If ctl.ControlType = acTextBox Or ctl.ControlType = acComboBox _
                Or ctl.ControlType = acCheckBox Or ctl.ControlType = acOptionButton _
                Or ctl.ControlType = acListBox Then
                    If ctl.Visible = True And ctl.Parent.Name = pg.Name Then
                    If ctl.HelpContextId = 1 Then bShift = False
                        If bShift = False Then
                            ipos = ctl.Top + ctl.Height
                            bShift = True
                        Else
                            If ctl.ControlType = acCheckBox Or ctl.ControlType = acOptionButton Then
                                ctl.Top = ipos + 60: ctl.Controls(0).Top = ipos + 20
                            Else
                                ctl.Top = ipos: ctl.Controls(0).Top = ipos
                            End If
                            ipos = ipos + ctl.Height
                        End If
                    End If
                End If
            Next ctl
        End If
Next pg
End Function

ReturnDaysInMonth

Mon, 12 Apr 2010 10:06:01 GMT

Description: Return a count of either all the days, only workdays, or weekend days of specified month/year.

Link: http://www.codekeep.net/snippets/95e65796-8096-4247-a2d1-915f7a81ac1a.aspx

Function ReturnDaysInMonth(vMonth As Variant, vYear As Variant, Optional DayType As String = "WorkDays") As Integer
Dim iDay As Integer
Dim dDateTest As Date
Dim iWeekendDays As Integer
Dim iDaysInMonth As Integer

On Error GoTo Error_Section

iWeekendDays = 0

For iDay = 1 To 32
    dDateTest = CDate(iDay & "/" & vMonth & "/" & vYear)
        If Left(Format(dDateTest, "ddd"), 1) = "S" Then iWeekendDays = iWeekendDays + 1
    iDaysInMonth = Format(dDateTest, "dd")
Next iDay

End_Proc:

Select Case DayType
    Case "All"
        'Do nothing - leave iDaysInMonth as it is
    Case "WorkDays"
        iDaysInMonth = iDaysInMonth - iWeekendDays
    Case "Weekend"
        iDaysInMonth = iWeekendDays
End Select

ReturnDaysInMonth = iDaysInMonth

Exit Function

Error_Section:
Select Case Err.Number
    Case 13
        Resume End_Proc
End Select

End Function

ShowOneToolBar

Fri, 19 Mar 2010 19:23:02 GMT

Description: Disable all toolbars except the one stipulated in ExceptionName argument plus all popups...

Link: http://www.codekeep.net/snippets/4606587a-48cb-4186-be32-1cf5c8dc2219.aspx

Function ShowOneToolBar(ExceptionName As String)
Dim i As Integer
For i = 1 To CommandBars.Count
        If CommandBars(i).Name <> ExceptionName Then
            If CommandBars(i).Type <> msoBarTypePopup Then CommandBars(i).Enabled = False
        Else
            CommandBars(i).Enabled = True
        End If
Next i
End Function