CodeKeep VBA Feed

Excel VBA: Convert To Hyperlinks

Thu, 01 Nov 2012 16:55:14 GMT

Description: Convert To Hyperlinks

Link: http://www.codekeep.net/snippets/1613989e-3906-44fd-a449-3e2726c40c0a.aspx

Public Sub Convert_To_Hyperlinks()
Dim Cell As Range
For Each Cell In Intersect(Selection, ActiveSheet.UsedRange)
If Cell <> "" Then
ActiveSheet.Hyperlinks.Add Cell, Cell.Value
End If
Next
End Sub

UnicodeDecode

Wed, 01 Aug 2012 10:45:23 GMT

Description: for converting string like "Phút giây gần nhau" to unicode

Link: http://www.codekeep.net/snippets/a5b3b62f-2182-4c1a-b3a2-71c9c234680e.aspx

Public Function UnicodeDecode(StringToDecode As String) As String
    'for converting string like "Ph&#250;t gi&#226;y g&#7847;n nhau" to unicode
  Dim TempAns As String
  Dim CurChr As Integer, iEnd As Integer
  CurChr = 1
   Do Until CurChr > Len(StringToDecode)
    Select Case Mid(StringToDecode, CurChr, 2)
    Case "&#"
        iEnd = InStr(CurChr + 2, StringToDecode, ";")
        TempAns = TempAns & ChrW(Mid(StringToDecode, CurChr + 2, iEnd - (CurChr + 2)))
        CurChr = iEnd
    Case Else
      TempAns = TempAns & Mid(StringToDecode, CurChr, 1)
    End Select
    CurChr = CurChr + 1
  Loop
  UnicodeDecode = TempAns
End Function

Export the notes text of a PowerPoint presentation

Mon, 02 Jan 2012 06: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 06: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 05: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 12: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 11: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 11: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

Excel ADO - Get Data from SQL Server

Tue, 28 Sep 2010 13:39:33 GMT

Description: Excel ADO - Get Data from SQL Server

Link: http://www.codekeep.net/snippets/ae22081d-8809-493b-9457-730c307042a0.aspx

Sub GetManagerEmployeeListSQL()

    Dim cnn As ADODB.Connection
    Dim cmd As ADODB.Command
    Dim param As ADODB.Parameter
    Dim rs As ADODB.Recordset
    Dim sConnString As String
    Dim i As Integer
    
    Dim xlSheet As Worksheet
    
    Set xlSheet = Sheets("Sheet1")
    xlSheet.Activate
    Range("A3").Activate
    Selection.CurrentRegion.Select
    Selection.ClearContents
    Range("A1").Select
    
    Set cnn = New ADODB.Connection
    sConnString = "Provider=SQLNCLI10;Server=XPS8300;Database=AdventureWorks2008R2;Trusted_Connection=yes;"
    cnn.Open sConnString
    
    Set cmd = New ADODB.Command
    cmd.ActiveConnection = cnn
    
    Set param = New ADODB.Parameter
    With param
        .Name = "BusinessEntityID"
        .Type = adInteger
        .Value = ActiveSheet.Range("A1").Value
    End With
    
    With cmd
        .CommandType = adCmdStoredProc
        .CommandText = "uspGetManagerEmployees"
        .Parameters.Append param
    End With
    
    Set rs = New ADODB.Recordset
    Set rs = cmd.Execute
    
    For i = 1 To rs.Fields.Count
        ActiveSheet.Cells(3, i).Value = rs.Fields(i - 1).Name
    Next i
    
    xlSheet.Range("A4").CopyFromRecordset rs
    
    xlSheet.Select
    Range("A3").Select
    Selection.CurrentRegion.Select
    Selection.Columns.AutoFit
    Range("A1").Select
    
    rs.Close
    cnn.Close
    Set cmd = Nothing
    Set param = Nothing
    Set rs = Nothing
    Set cnn = Nothing
    Set xlSheet = Nothing
    

End Sub

DuplicateRecord

Mon, 24 May 2010 10: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 10: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 04: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 04: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 03: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 03: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 06: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 07: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 06: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 06: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 04: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 04: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 06: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 08: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 06: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 06: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