Loading...
 

Excel Macros

Home

Date into Text

  • Date in B2
  • =TEXT(B2,"dd-mmm-yy")

Fold Elements From Column To Table

  • File not found.
  • Sub foldElementsFromColumnToTable()
    Dim topRow, topColumn, bottomRow, numberElements, counterRow As Long

    numberElements = 2
    topRow = ActiveCell.Row
    topColumn = ActiveCell.Column
    bottomRow = ActiveCell.End(xlDown).Row

    If ((bottomRow - topRow + 1) Mod numberElements) <> 0 Then
        MsgBox ("There should be a multiple of " & numberElements & " items")
        Exit Sub
    End If

    Application.ScreenUpdating = False
    For counterRow = 1 To (bottomRow - topRow)
        Cells(topRow + Int(counterRow / numberElements), _
            topColumn + (counterRow Mod numberElements)).Value = _
            Cells(topRow + counterRow, topColumn).Value
        Cells(topRow + counterRow, topColumn).Value = ""
    Next counterRow
    Application.ScreenUpdating = True
    
End Sub

removeLeft

  • Function removeLeft(inString As String, numberCharacters As Integer) As String
    If numberCharacters <= 0 Then
        removeLeft = inString
        Exit Function
    End If
    If numberCharacters >= Len(inString) Then
        removeLeft = ""
        Exit Function
    End If
    removeLeft = Right(inString, Len(inString) - numberCharacters)
End Function

removeRight

  • Function removeRight(inString As String, numberCharacters As Integer) As String
    If numberCharacters <= 0 Then
        removeRight = inString
        Exit Function
    End If
    If numberCharacters >= Len(inString) Then
        removeRight = ""
        Exit Function
    End If
    removeRight = Left(inString, Len(inString) - numberCharacters)
End Function

charAt

  • Function charAt(inString As String, place As Integer) As String
    If place <= 0 Or place > Len(inString) Then
        Err.Raise 513, "charAt", "place out of bounds"
    End If
    charAt = Mid(inString, place, 1)
End Function

likeAt

  • Function likeAt(inString As String, inPattern As String, Optional startPosition As Integer = 1) As Integer
    Dim counter As Integer
    If startPosition <= 0 Or startPosition > Len(inString) Then
        Err.Raise 514, "likeAt", "startPosition out of bounds"
    End If

    For counter = startPosition To Len(inString)
        If charAt(inString, counter) Like inPattern Then
            likeAt = counter
            Exit Function
        End If
    Next counter
    likeAt = 0
End Function

likeAtRev

  • Function likeAtRev(inString As String, inPattern As String, Optional inStartPosition As Variant) As Integer
    Dim counter As Integer
    Dim startPosition As Integer
    
    If IsMissing(inStartPosition) Then
        startPosition = Len(inString)
    Else
        If IsNumeric(inStartPosition) Then
            startPosition = CInt(inStartPosition)
            If startPosition <= 0 Or startPosition > Len(inString) Then
                Err.Raise 515, "likeAtRev", "inStartPosition out of bounds"
            End If
        Else
            Err.Raise 516, "likeAtRev", "inStartPosition must be an integer"
        End If
    End If
    
    For counter = startPosition To 1 Step -1
        If charAt(inString, counter) Like inPattern Then
            likeAt = counter
            Exit Function
        End If
    Next counter
    likeAt = 0
End Function

extractTwitterName

  • Function extractTwitterName(inString As String) As String
    Dim webAddresses(0 To 11) As String
    Dim emailAddresses(0 To 5) As String
    Dim counter As Long
    Dim twitterName As String
    Dim likeAtPos As Integer

    twitterName = inString

    webAddresses(0) = "http://twitter.com/"
    webAddresses(1) = "https://twitter.com/"
    webAddresses(2) = "http://www.twitter.com/"
    webAddresses(3) = "https://www.twitter.com/"
    webAddresses(4) = "www.twitter.com/"
    webAddresses(5) = "twitter.com/"
    webAddresses(6) = "http://twiter.com/"
    webAddresses(7) = "https://twiter.com/"
    webAddresses(8) = "http://www.twiter.com/"
    webAddresses(9) = "https://www.twiter.com/"
    webAddresses(10) = "www.twiter.com/"
    webAddresses(11) = "twiter.com/"

    emailAddresses(0) = "@www.twitter.com"
    emailAddresses(1) = "@twitter.com"
    emailAddresses(2) = "@twitter"
    emailAddresses(3) = "@www.twiter.com"
    emailAddresses(4) = "@twiter.com"
    emailAddresses(5) = "@twiter"

    For counter = LBound(webAddresses) To UBound(webAddresses)
        If InStr(UCase(twitterName), UCase(webAddresses(counter))) = 1 Then
            twitterName = removeLeft(twitterName, Len(webAddresses(counter)))
        End If
    Next counter

    For counter = LBound(emailAddresses) To UBound(emailAddresses)
        If InStr(StrReverse(UCase(twitterName)), StrReverse(UCase(emailAddresses(counter)))) = 1 Then
            twitterName = removeRight(twitterName, Len(emailAddresses(counter)))
        End If
    Next counter

    If charAt(twitterName, 1) = "@" Then
        twitterName = removeLeft(twitterName, 1)
    End If

    likeAtPos = likeAt(UCase(twitterName), "[!A-Z0-9_]")
    If likeAtPos > 0 Then
        twitterName = Left(twitterName, likeAtPos - 1)
    End If

    extractTwitterName = "@" + twitterName
End Function

extractFacebookName

  • Function extractFacebookName(inString As String) As String
    Dim midDelimiter(0 To 0) As String
    Dim webAddresses(0 To 37) As String
    Dim emailAddresses(0 To 3) As String
    Dim counter As Long
    Dim facebookName As String
    Dim matchPosition As Integer

    facebookName = inString

    midDelimiter(0) = "#!/"

    webAddresses(0) = "http://facebook.com/"
    webAddresses(1) = "https://facebook.com/"
    webAddresses(2) = "http://www.facebook.com/"
    webAddresses(3) = "https://www.facebook.com/"
    webAddresses(4) = "http://www.facebook/"
    webAddresses(5) = "https://www.facebook/"
    webAddresses(6) = "http://m.facebook.com/"
    webAddresses(7) = "https://m.facebook.com/"
    webAddresses(8) = "http://m.facebook/"
    webAddresses(9) = "https://m.facebook/"
    webAddresses(10) = "http://facebook/"
    webAddresses(11) = "https://facebook/"
    webAddresses(12) = "www.facebook.com/"
    webAddresses(13) = "www.facebook/"
    webAddresses(14) = "www.m.facebook/"
    webAddresses(15) = "m.facebook.com/"
    webAddresses(16) = "m.facebook/"
    webAddresses(17) = "facebook.com/"
    webAddresses(18) = "facebook/"
    webAddresses(19) = "http://facebok.com/"
    webAddresses(20) = "https://facebok.com/"
    webAddresses(21) = "http://www.facebok.com/"
    webAddresses(22) = "https://www.facebok.com/"
    webAddresses(23) = "http://www.facebok/"
    webAddresses(24) = "https://www.facebok/"
    webAddresses(25) = "http://m.facebok.com/"
    webAddresses(26) = "https://m.facebok.com/"
    webAddresses(27) = "http://m.facebok/"
    webAddresses(28) = "https://m.facebok/"
    webAddresses(29) = "http://facebok/"
    webAddresses(30) = "https://facebok/"
    webAddresses(31) = "www.facebok.com/"
    webAddresses(32) = "www.facebok/"
    webAddresses(33) = "www.m.facebok/"
    webAddresses(34) = "m.facebok.com/"
    webAddresses(35) = "m.facebok/"
    webAddresses(36) = "facebok.com/"
    webAddresses(37) = "facebok/"

    emailAddresses(0) = "@www.facebook.com"
    emailAddresses(1) = "@m.facebook.com"
    emailAddresses(2) = "@facebook.com"
    emailAddresses(3) = "@facebook"

    matchPosition = InStr(UCase(facebookName), UCase("profile.php?id="))
    If matchPosition > 0 Then
        facebookName = removeLeft(facebookName, matchPosition - 1)
        matchPosition = likeAt(facebookName, "[!0-9]", 16)
        If matchPosition > 0 Then
            facebookName = Left(facebookName, matchPosition - 1)
        End If
    Else

        For counter = LBound(midDelimiter) To UBound(midDelimiter)
            matchPosition = InStr(UCase(facebookName), UCase(midDelimiter(counter)))
            If matchPosition > 0 Then
                facebookName = removeLeft(facebookName, matchPosition + Len(midDelimiter(counter)) - 1)
            End If
        Next counter
    
        For counter = LBound(webAddresses) To UBound(webAddresses)
            If InStr(UCase(facebookName), UCase(webAddresses(counter))) = 1 Then
                facebookName = removeLeft(facebookName, Len(webAddresses(counter)))
            End If
        Next counter
    
        For counter = LBound(emailAddresses) To UBound(emailAddresses)
            If InStr(StrReverse(UCase(facebookName)), StrReverse(UCase(emailAddresses(counter)))) = 1 Then
                facebookName = removeRight(facebookName, Len(emailAddresses(counter)))
            End If
        Next counter
    
        matchPosition = InStr(facebookName, "?")
        If matchPosition > 0 Then
            facebookName = Left(facebookName, matchPosition - 1)
        End If
    End If
    
    extractFacebookName = "facebook.com/" + facebookName
End Function

Table To HTML

  • Sub tableToHTML()
    Dim tableTop, tableLeft, tableRight, tableBottom, counterRow, counterColumn As Integer
    Dim outputString As String
    
    tableTop = ActiveCell.Row
    tableLeft = ActiveCell.Column
    tableRight = ActiveCell.End(xlToRight).Column
    tableBottom = ActiveCell.End(xlDown).Row
    
    outputString = "<table>" & vbCrLf
    For counterRow = tableTop To tableBottom
        outputString = outputString & vbTab & "<tr>" & vbCrLf
        For counterColumn = tableLeft To tableRight
            outputString = outputString & vbTab & vbTab
            If counterRow = tableTop Then
                outputString = outputString & "<th>"
            Else
                outputString = outputString & "<td>"
            End If
            outputString = outputString & Cells(counterRow, counterColumn).Value
            If counterRow = tableTop Then
                outputString = outputString & "</th>"
            Else
                outputString = outputString & "</td>"
            End If
            outputString = outputString & vbCrLf
        Next counterColumn
        outputString = outputString & vbTab & "</tr>" & vbCrLf
    Next counterRow
    outputString = outputString & "</table>" & vbCrLf
        
    Cells(tableBottom + 1, tableLeft).Value = outputString
End Sub