Loading...
 

Excel Macros

Home

Date into Text

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

Fold Elements From Column To Table

  •  Plugin Image
    File not found.
  • Copy to clipboard
    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

  • Copy to clipboard
    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

  • Copy to clipboard
    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

  • Copy to clipboard
    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

  • Copy to clipboard
    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

  • Copy to clipboard
    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

  • Copy to clipboard
    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

  • Copy to clipboard
    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

  • Copy to clipboard
    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