Loading...
 

Excel Macros

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