Option Explicit ' ---- mod_join -- David McRitchie ...version 2003-10-20 'Not all have been tested for use with Option Explicit ' http://www.mvps.org/dmcritchie/excel/join.htm .../code/join.htm Sub Join() 'David McRitchie 08/05/1998 [Ctrl+j] documented in ' http://www.mvps.org/dmcritchie/excel/excel.htm 'Join cells in selected portion of a row together 'can be used as a reversal of Data/Test2cols or SepTerm() Dim iCols As Long, mRow As Long, lastcell As Range Dim iAnswer As Variant, l As Long, im As Long, newcell As String Dim ic As Long, ir As Long, iRows As Long, trimmed As String Application.ScreenUpdating = False On Error Resume Next iRows = Selection.Rows.Count Set lastcell = Cells.SpecialCells(xlLastCell) mRow = lastcell.Row If mRow < iRows Then iRows = mRow 'not best but better than nothing iCols = Selection.Columns.Count For ir = 1 To iRows newcell = Trim(Selection.Item(ir, 1).Value) For ic = 2 To iCols trimmed = Trim(Selection.Item(ir, ic).Value) If Len(trimmed) <> 0 Then newcell = newcell & " " & trimmed Selection.Item(ir, ic) = "" Next ic Selection.Item(ir, 1).Value = newcell Next ir Application.ScreenUpdating = True End Sub Sub JoinRows() 'David McRitchie 2003-06-16 programming, documented in ' http://www.mvps.org/dmcritchie/excel/join.htm 'Join cells with CHAR(10) to cell above within selection Dim iCols As Long, mRow As Long, lastcell As Range Dim iAnswer As Variant, l As Long, im As Long Dim ic As Long, ir As Long, iRows As Long, trimmed As String Dim response As Long If Selection.Columns.Count <> Cells.Columns.Count Then response = MsgBox("You did not select entire rows" & Chr(10) _ & "Press OK to continue anyway (rows may not line up)" _ & Chr(10) & "Press Cancel to terminate", vbOKCancel) If response = vbCancel Then Exit Sub End If Application.ScreenUpdating = False On Error Resume Next iRows = Selection.Rows.Count Set lastcell = Cells.SpecialCells(xlLastCell) mRow = lastcell.Row If mRow < iRows Then iRows = mRow 'not best but better than nothing iCols = Selection.Columns.Count For ir = iRows To 2 Step -1 For ic = 1 To iCols If Trim(Selection.Item(ir, ic).Value) <> "" Then If Trim(Selection.Item(ir - 1, ic).Value) <> "" Then Selection.Item(ir - 1, ic).Value = Selection.Item(ir - 1, ic) _ & Chr(10) & Selection.Item(ir, ic) Else Selection.Item(ir - 1, ic).Value = Selection.Item(ir, ic) End If End If Next ic Selection.Item(ir, 1).Resize(1, iCols).Delete Next ir Selection.Resize(1).Select With Selection .VerticalAlignment = xlTop .WrapText = True End With Application.ScreenUpdating = True End Sub Sub Prefix160() 'Prefix all selected cells with string or Required Blank ascii(160) 'David McRitchie, 2000-09-24, S/B documented in ' http://www.mvps.org/dmcritchie/excel/join.htm Application.ScreenUpdating = False Application.Calculation = xlCalculationManual 'pre XL97 xlManual Dim cell As Range Dim prefix As String prefix = InputBox("Specify prefix for all cells in selection " _ & Chr(10) & " default is ascii(160) ""required blank""", _ "Supply Prefix", Chr(160)) For Each cell In Selection cell.Value = prefix & cell.Value Next cell Application.Calculation = xlCalculationAutomatic 'pre XL97 xlAutomatic Application.ScreenUpdating = True End Sub Sub PrefixChars() 'Prefix all selected text cells with a Letter 'David McRitchie, 2003-08-19 modification of Prefix160 ' http://www.mvps.org/dmcritchie/excel/join.htm Dim cell As Range Dim prefix As String On Error Resume Next 'In case no cells in selection prefix = InputBox("Specify prefix characters for all text " _ & "cells in selection " & Chr(10) & " default is Letter E", _ "Supply Prefix", "E") If prefix = "" Then Exit Sub Application.ScreenUpdating = False Application.Calculation = xlCalculationManual 'pre XL97 xlManual For Each cell In Intersect(Selection, _ Selection.SpecialCells(xlConstants, xlTextValues)) cell.Value = prefix & cell.Value Next cell Application.Calculation = xlCalculationAutomatic 'pre XL97 xlAutomatic Application.ScreenUpdating = True End Sub Sub Enclose_Text_cells() Dim tstRange As Range, cell As Range On Error Resume Next Set tstRange = Intersect(Selection, _ Selection.SpecialCells(xlConstants, xlTextValues)) On Error GoTo 0 If tstRange Is Nothing Then Exit Sub Application.ScreenUpdating = False Application.Calculation = xlCalculationManual For Each cell In tstRange cell.Value = "(" & Trim(cell.Formula) & ")" Next cell Application.Calculation = xlCalculationAutomatic Application.ScreenUpdating = True End Sub Sub SepTerm() 'David McRitchie 08/05/1998 [Ctrl+t] documented in ' http://www.mvps.org/dmcritchie/excel/excel.htm 'Separate the first term from remainder, as in separating 'street number as first item from street & remainder 'Work on first column, cell to right must appear to be blank '--Application.ScreenUpdating = False Dim iRows As Long, mRow As Long, lastcell As Range, ir As Long Dim iAnswer As Variant, l As Long, im As Long, checkx As String 'On Error Resume Next iRows = Selection.Rows.Count Set lastcell = Cells.SpecialCells(xlLastCell) mRow = lastcell.Row If mRow < iRows Then iRows = mRow 'not best but better than nothing For ir = 1 To iRows If Len(Trim(Selection.Item(ir, 1).Offset(0, 1))) <> 0 Then iAnswer = MsgBox("Found non-blank in adjacent column -- " _ & Selection.Item(ir, 1).Offset(0, 1) & " -- in " & _ Selection.Item(ir, 1).Offset(0, 1).AddressLocal(0, 0) & _ Chr(10) & "Press OK to process those than can be split", _ vbOKCancel) If iAnswer = vbOK Then GoTo DoAnyWay GoTo terminated End If Next ir DoAnyWay: For ir = 1 To iRows If Len(Trim(Selection.Item(ir, 1).Offset(0, 1))) <> 0 _ Then GoTo NextRow checkx = Trim(Selection.Item(ir, 1)) l = Len(Trim(Selection.Item(ir, 1))) If l < 3 Then GoTo NextRow For im = 2 To l If Mid(checkx, im, 1) = " " Then Selection.Item(ir, 1) = Left(checkx, im - 1) Selection.Item(ir, 1).Offset(0, 1) = Trim(Mid(checkx, im + 1)) GoTo NextRow End If Next im NextRow: Next ir terminated: '--Application.ScreenUpdating = True End Sub Sub AbbreviateStates() Application.ScreenUpdating = False Application.Calculation = xlCalculationManual 'pre XL97 xlManual Selection.Replace What:=", Alaska", replacement:=", AK" Selection.Replace What:=", Alabama", replacement:=", AL" Selection.Replace What:=", Arkansas", replacement:=", AR" Selection.Replace What:=", Arizona", replacement:=", AZ" Selection.Replace What:=", California", replacement:=", CA" Selection.Replace What:=", Colorado", replacement:=", CO" Selection.Replace What:=", Connecticut", replacement:=", CT" Selection.Replace What:=", District of Columbia", replacement:=", DC" Selection.Replace What:=", Delaware", replacement:=", DE" Selection.Replace What:=", Florida", replacement:=", FL" Selection.Replace What:=", Georgia", replacement:=", GA" Selection.Replace What:=", Hawaii", replacement:=", HI" Selection.Replace What:=", Iowa", replacement:=", IA" Selection.Replace What:=", Idaho", replacement:=", ID" Selection.Replace What:=", Illinois", replacement:=", IL" Selection.Replace What:=", Indiana", replacement:=", IN" Selection.Replace What:=", Kansas", replacement:=", KS" Selection.Replace What:=", Kentucky", replacement:=", KY" Selection.Replace What:=", Louisiana", replacement:=", LA" Selection.Replace What:=", Massachusetts", replacement:=", MA" Selection.Replace What:=", Maryland", replacement:=", MD" Selection.Replace What:=", Maine", replacement:=", ME" Selection.Replace What:=", Michigan", replacement:=", MI" Selection.Replace What:=", Minnesota", replacement:=", MN" Selection.Replace What:=", Missouri", replacement:=", MO" Selection.Replace What:=", Mississippi", replacement:=", MS" Selection.Replace What:=", Montana", replacement:=", MT" Selection.Replace What:=", North Carolina", replacement:=", NC" Selection.Replace What:=", North Dakota", replacement:=", ND" Selection.Replace What:=", Nebraska", replacement:=", NE" Selection.Replace What:=", New Hampshire", replacement:=", NH" Selection.Replace What:=", New Jersey", replacement:=", NJ" Selection.Replace What:=", New Mexico", replacement:=", NM" Selection.Replace What:=", Nevada", replacement:=", NV" Selection.Replace What:=", New York", replacement:=", NY" Selection.Replace What:=", Ohio", replacement:=", OH" Selection.Replace What:=", Oklahoma", replacement:=", OK" Selection.Replace What:=", Oregon", replacement:=", OR" Selection.Replace What:=", Pennsylvania", replacement:=", PA" Selection.Replace What:=", Rhode Island", replacement:=", RI" Selection.Replace What:=", South Carolina", replacement:=", SC" Selection.Replace What:=", South Dakota", replacement:=", SD" Selection.Replace What:=", Tennessee", replacement:=", TN" Selection.Replace What:=", Texas", replacement:=", TX" Selection.Replace What:=", Utah", replacement:=", UT" Selection.Replace What:=", Virginia", replacement:=", VA" Selection.Replace What:=", Vermont", replacement:=", VT" Selection.Replace What:=", Washington", replacement:=", WA" Selection.Replace What:=", Wisconsin", replacement:=", WI" Selection.Replace What:=", West Virginia", replacement:=", WV" Selection.Replace What:=", Wyoming", replacement:=", WY" Selection.Replace What:="gton Piers,", replacement:="gton," Selection.Replace What:=", Alberta", replacement:=", AB" Selection.Replace What:=", British Columbia", replacement:=", BC" Selection.Replace What:=", Manitoba", replacement:=", MB" Selection.Replace What:=", New Brunswick", replacement:=", NB" Selection.Replace What:=", Newfoundland", replacement:=", NF" Selection.Replace What:=", Nova Scotia", replacement:=", NS" Selection.Replace What:=", Ontario", replacement:=", ON" Selection.Replace What:=", Quebec", replacement:=", QC" Selection.Replace What:=", Saskatchewan", replacement:=", SK" Application.Calculation = xlCalculationAutomatic 'pre XL97 xlAutomatic Application.ScreenUpdating = True End Sub Sub SepLastTerm() 'David McRitchie 08/20/1998 [Ctrl+l] documented in ' http://www.mvps.org/dmcritchie/excel/excel.htm 'Separate the last term from remainder, as in separating 'lastname from firstname 'Work on first column, cell to right must appear to be blank Application.ScreenUpdating = False Dim iRows As Long, mRow As Long, lastcell As Range, ir As Long Dim iAnswer As Variant, l As Long, im As Long, checkx As String 'On Error Resume Next iRows = Selection.Rows.Count Set lastcell = Cells.SpecialCells(xlLastCell) mRow = lastcell.Row If mRow < iRows Then iRows = mRow 'not best but better than nothing For ir = 1 To iRows If Len(Trim(Selection.Item(ir, 1).Offset(0, 1))) <> 0 Then iAnswer = MsgBox("Found non-blank in adjacent column -- " _ & Selection.Item(ir, 1).Offset(0, 1) & " -- in " & _ Selection.Item(ir, 1).Offset(0, 1).AddressLocal(0, 0) & _ Chr(10) & "Press OK to process those than can be split", _ vbOKCancel) If iAnswer = vbOK Then GoTo DoAnyWay GoTo terminated End If Next ir DoAnyWay: For ir = 1 To iRows If Len(Trim(Selection.Item(ir, 1).Offset(0, 1))) <> 0 _ Then GoTo NextRow checkx = Trim(Selection.Item(ir, 1)) l = Len(Trim(Selection.Item(ir, 1))) If l < 3 Then GoTo NextRow '-- this is where SepLastTerm differs from SepTerm For im = l - 1 To 2 Step -1 If Mid(checkx, im, 1) = " " Then Selection.Item(ir, 1) = Left(checkx, im - 1) Selection.Item(ir, 1).Offset(0, 1) = Trim(Mid(checkx, im + 1)) GoTo NextRow End If Next im NextRow: Next ir terminated: '--Application.ScreenUpdating = True End Sub Sub SepLastWord() ' David McRitchie, 2003-01-16 not posted ' documented in http://www.mvsp.org/dmcritchie/join.htm#seplastword ' uses strreverse not available prior to Excel 97 (or is it 2000) '--no checking that adjacent cell is empty, unlike SepTerm Dim rng As Range, cell As Range, I As Long Set rng = Intersect(Selection, _ ActiveCell.EntireColumn.SpecialCells(xlConstants, xlTextValues)) If rng Is Nothing Then MsgBox "Select a range within one column WITHIN USED RANGE" Exit Sub End If Application.ScreenUpdating = False Application.Calculation = xlCalculationManual For Each cell In rng I = InStr(1, strReverse(cell), " ", vbBinaryCompare) cell.Offset(0, 1).Formula = "'" & _ Application.Trim(Right(cell, Application.Max(0, I - 1))) cell.Formula = "'" & Application.Trim(Left(cell.Value, Len(cell) - I)) Next cell Application.Calculation = xlCalculationAutomatic Application.ScreenUpdating = True End Sub Sub SepLastName() ' David McRitchie, 2003-01-16 not posted ' documented in http://www.mvsp.org/dmcritchie/join.htm#seplastName ' uses strreverse not available prior to Excel 97 (or is it 2000) ' same as SepLastWord except will look for de, mc, mac, di, von, van ' this macro will not fix the letter case of any name '--no checking that adjacent cell is empty, unlike SepTerm Dim rng As Range, cell As Range, I As Long, j As Long, k As Long Set rng = Intersect(Selection, _ ActiveCell.EntireColumn.SpecialCells(xlConstants, xlTextValues)) If rng Is Nothing Then MsgBox "Select a range within one column WITHIN USED RANGE" Exit Sub End If Dim SSS As String Dim AAA(3) As String ' Application.ScreenUpdating = False ' Application.Calculation = xlCalculationManual For Each cell In rng SSS = " " & Trim(cell) 'must find spaces I = InStr(1, strReverse(SSS), " ", vbBinaryCompare) j = InStr(I + 1, strReverse(SSS), " ", vbBinaryCompare) AAA(3) = Right(SSS, I - 1) AAA(2) = Trim(Mid(SSS, Len(SSS) - j + 2, j - I - 1)) AAA(1) = Trim(Left(SSS, Len(SSS) - j)) I = InStr(" DE DER DI MC MAC VAN VON ", _ " " & UCase(AAA(2)) & " ") If I > 0 Then cell = AAA(1) cell.Offset(0, 1) = AAA(2) & " " & AAA(3) Else cell.Formula = Trim(AAA(1) & " " & AAA(2)) cell.Offset(0, 1).Formula = AAA(3) End If Next cell Application.Calculation = xlCalculationAutomatic Application.ScreenUpdating = True End Sub Function LastWord(s As String, Optional Character As String = " ") As String ' Returns last word(based on spaces), with optional delimiter character ' Excel 2000 only ' By: Dana DeLouis in worksheet.functions 2000-02-21 '=LASTWORD("c:\work\january\book.xls","\") ' gives: book.xls Dim V As Variant V = Split(Trim(s), Character, -1) 'returns all substrings in an array LastWord = V(UBound(V)) 'last item in the array End Function Sub ReversI() 'David McRitchie 07/30/1998 documented in ' http://www.mvps.org/dmcritchie/excel/excel.htm 'Reverse (Flip) Item values in Range, Row, or Column [Ctrl+R] 'Counting in multiple rows/cols, item count proceeds down a 'column in range and continues top of next column in range Dim tcells As Long, mCells As Long, ix As Long, ox As Long iValue As Variant tcells = Selection.Count mCells = tcells / 2 For ix = 1 To mCells iValue = Selection.Item(ix).Value ox = tcells + 1 - ix Selection.Item(ix).Value = Selection.Item(ox).Value Selection.Item(ox).Value = iValue Next ix End Sub Sub RotateCW() 'Rotate Clockwise: 1) Rotate rows, 2) TRANSPOSE & delete orig 'David McRitchie, 2000-02-07 MISC rev 2002-01-26, documented in ' http://www.mvps.org/dmcritchie/excel/join.htm 'Cell A1 must be in Selection !!!!! 'must formatting and Formulas are preserved 'testing... leave in won't hurt... If ActiveSheet.Name = "RotateCW.Master (2)" Then Sheets("RotateCW.Master (2)").Delete MsgBox "try again have deleted RotateCW.Master (2)" Exit Sub End If If UCase(ActiveSheet.Name) = UCase("RotateCW.Master") Then _ Sheets("RotateCW.Master").Copy Before:=Sheets("RotateCW.Master") Dim I As Long, str As String, str2 As String Dim nRows As Long, nRowsX As String, nCols As Long Dim nRowsP As Long str = Selection.Item(Selection.Count).Address str = Range("A1:" & str).Address nRows = Application.Min(256, Application.Max(Range(str).Rows.Count, _ Range(str).Columns.Count)) nRowsX = InputBox("Specify number of rows (including Cell A1)," _ & Chr(10) & "number of columns will be same as number of rows)" _ & " suggesting " & nRows, _ "Selection of Number of rows to Rotate", nRows) If nRowsX = "" Then GoTo done 'Check for cancellation nRows = nRowsX + 0: nRowsP = nRows + 1 If nRows > 256 Then MsgBox "Can't process more than 256 due to Column Restriction" Exit Sub End If str = Cells(1, 1).Resize(1, nRows).Address(0, 0) str2 = Cells(1, 1).Resize(nRows, nRows).Address(0, 0) Application.ScreenUpdating = False Application.Calculation = xlCalculationManual 'pre XL97 xlManual For I = nRowsP To 2 Step -1 Range(str).Select Selection.Cut 'i.e. A1:A13 Cells(I, 1).Select Selection.Insert Shift:=xlDown Next I Application.ScreenUpdating = True 'Have flipped the rows, next step is to TRANSPOSE data with copy Range(str2).Select I = MsgBox("Flipping of Rows Completed. Do you want to continue " & _ "with a TRANSPOSE using COPY?", vbOKCancel, "Question") If I <> 1 Then GoTo done Application.ScreenUpdating = False Selection.Copy Cells(nRowsP, 1).Insert Shift:=xlDown Cells(nRowsP, 1).Resize(nRows, nRows).Copy Cells(1, 1).PasteSpecial Paste:=xlAll, Operation:=xlNone, SkipBlanks:=False _ , Transpose:=True Cells(nRowsP, 1).Resize(nRows, nRows).Delete done: Cells(1, 1).Select Application.Calculation = xlCalculationAutomatic 'pre XL97 xlAutomatic Application.ScreenUpdating = True End Sub Sub RotateH() 'Rotate Horizontally (vertical axis) a: 1) Rotate rows, 2) TRANSPOSE & delete orig 'David McRitchie, 2000-07-27 MISC., documented in ' http://www.mvps.org/dmcritchie/excel/join.htm 'Cell A1 must be in Selection !!!!! 'must formatting and Formulas are preserved Application.ScreenUpdating = False Application.Calculation = xlCalculationManual 'pre XL97 xlManual Dim I As Long Dim nRows As Long '//to provide for rows avail. in XL97&UP Dim nCols As Long Dim curRange As Range Dim abc As String ' Dim sRow As Long Set curRange = Selection nRows = Selection.Rows.Count nCols = Selection.Columns.Count ' sRow = ActiveCell.Row scol = ActiveCell.Column If nRows > 256 Then Exit Sub nRows = InputBox("Specify number of rows, suggesting " & nRows, _ "Selection of Number of rows to Rotate", Selection.Rows.Count) nRows = nRows + 1 'adjustment for inserts For I = nRows To 2 Step -1 Rows(1).Select Selection.Cut Rows(I).Select Selection.Insert Shift:=xlUp Next I Application.Calculation = xlCalculationAutomatic 'pre XL97 xlAutomatic Application.ScreenUpdating = True End Sub Sub Switch_Minus() 'Chip Pearson, Misc, 1999-11-10 as ConvertTextValues 'To convert "numbers" that have minus sign on right as from mainframe Dim rng As Range For Each rng In Selection.SpecialCells(xlCellTypeConstants, _ xlTextValues) With rng If Right(.Value, 1) = "-" Then .Value = -1 * Left(.Value, Len(.Value) - 1) End If End With Next rng End Sub Sub arnd() Application.ScreenUpdating = False 'For i = 1 to Application.ScreenUpdating = True End Sub Sub psu() ' previously selected range, recorded 07/21/1998 by F. David McRitchie ' Range("F11:I16").Select '(or something like already suggested) 'Range(cells(1, 1), ActiveCell).Select ActiveSheet.PageSetup.PrintArea = Selection.Address End Sub Sub aremdups() 'chip pearson 7/22/98 Dim R As Long Dim c As Range Dim V As Variant Dim rng As Range Dim NewIndex As Long On Error GoTo EndMacro NewIndex = 1 Application.ScreenUpdating = False Application.Calculation = xlManual 'xl97 -- xlCalculationManual If Selection.Rows.Count > 1 Then Set rng = Selection Else Set rng = ActiveSheet.UsedRange.Rows End If For R = rng.Rows.Count To 1 Step -1 V = rng.Cells(R, 1).Value If Application.WorksheetFunction.CountIf(rng.Columns(1), V) > 1 Then Worksheets("Sheet2").Cells(NewIndex, 1).Value = rng.Cells(R, 1).Value NewIndex = NewIndex + 1 End If Next R EndMacro: Application.ScreenUpdating = True Application.Calculation = xlAutomatic End Sub Sub lastwhat() ' Don't know why everybody wants to wipe out the first worksheet ' Worksheets(1).Activate On Error Resume Next 'Bypass OLE automation 440 error 'cells(1, 3) = ActiveWorkbook.BuiltinDocumentProperties(12).Value Dim rw As Long, p As Variant rw = 1 For Each p In ActiveWorkbook.BuiltinDocumentProperties Cells(rw, 1).Value = p.Name Cells(rw, 2).Value = "xxxx" Cells(rw, 2).Value = ActiveWorkbook.BuiltinDocumentProperties(p.Name).Value If Err Then Cells(rw, 2).Value = "Not defined" rw = rw + 1 Next p 'On Error GoTo 0 'have no idea what this is supposed to do... End Sub Sub LeftToSpace() 'David McRitchie posted 1999-11-16 in misc ' also handles blank cells, and cells w/o space ' similiar to: =LEFT(A9,FIND(" ",A9&" ")-1) Dim I As Long Application.ScreenUpdating = False Application.Calculation = xlCalculationManual 'pre XL97 xlManual For I = 1 To Selection.Count Selection.Item(I).Value = Left(Selection.Item(I), InStr(Selection.Item(I).Value & " ", " ") - 1) Next I Application.Calculation = xlCalculationAutomatic 'pre XL97 xlAutomatic Application.ScreenUpdating = True End Sub Sub todaytxt() ActiveCell.Formula = Now() End Sub Function GetActiveCell() Application.Volatile GetActiveCell = Application.ActiveCell.Address End Function Function WordCount(txt, Separator) As Long ' David McRitchie http://www.mvps.org/dmcritchie/excel/wordcnt.htm ' Returns a Count of Words in a text string, where the elements ' are separated by a specified separator character ' beginning and trailing spaces are eliminated first though. ' Coding is derived from coding for ExtractElement ' at http://www.j-walk.com/ss/excel/tips/tip32.htm Dim Txt1 As String, temperament As String Dim ElementCount As Long, I As Long Separator1 = Separator If Separator = "" Then Separator1 = " " LastTxt1 = Separator1 Txt1 = txt ' If space separator, remove excess spaces ' If Separator = Chr(32) Then Txt1 = Application.Trim(Txt1) ' Eliminated beginning and trailing spaces regardless of separator Txt1 = Application.Trim(Txt1) ' Add a separator to the end of the string If Right(Txt1, Len(Txt1)) <> Separator1 Then Txt1 = Txt1 & Separator1 ' Initialize ElementCount = 0 ' Extract each element -- count adjacent separators as one For I = 1 To Len(Txt1) If Mid(Txt1, I, 1) <> LastTxt1 Then If Mid(Txt1, I, 1) = Separator1 Then ElementCount = ElementCount + 1 End If End If LastTxt1 = Mid(Txt1, I, 1) Next I WordCount = ElementCount End Function 'Wordcount 'Returns the nth element of a text string Function ExtractElement(txt, n, Separator) As String ' Returns the nth element of a text string, where the elements ' are separated by a specified separator character ' Original version of ExtractElement coding found ' at http://www.j-walk.com/ss/excel/tips/tip32.htm ' Modified version by D.McRitchie eliminates redundant separators ' in http://www.mvps.org/dmcritchie/excel/wordcnt.htm Dim Txt1 As String, temperament As String Dim ElementCount As Long, I As Long Txt1 = txt ' If space separator, remove excess spaces ' If Separator = Chr(32) Then Txt1 = Application.Trim(Txt1) ' Eliminated beginning and trailing spaces regardless of separator Txt1 = Application.Trim(Txt1) Lastsep = 1 ' Add a separator to the end of the string If Right(Txt1, Len(Txt1)) <> Separator Then Txt1 = Txt1 & Separator ' Initialize ElementCount = 0 TempElement = "" ' Extract each element For I = 1 To Len(Txt1) If Mid(Txt1, I, 1) = Separator Then If Lastsep = 1 Then GoTo nexti ElementCount = ElementCount + 1 If ElementCount = n Then ' Found it, so exit ExtractElement = TempElement Exit Function Else TempElement = "" End If Else TempElement = TempElement & Mid(Txt1, I, 1) Lastsep = 0 End If nexti: Next I ExtractElement = "" End Function 'ExtractElement Sub LastName() 'David McRitchie 1999-04-09 ' http://www.mvps.org/dmcritchie/excel/excel.htm 'Put cells in range in as Lastname, firstnames '--Application.ScreenUpdating = False 'On Error Resume Next Dim iRows As Long, mRow As Long, iMax As Long, l As Long Dim ir As Long, im As Long iRows = Selection.Rows.Count Set lastcell = Cells.SpecialCells(xlLastCell) mRow = lastcell.Row If iRows > mRow Then iRows = mRow iMax = -1 For ir = 1 To iRows checkx = Trim(Selection.Item(ir, 1)) l = Len(Trim(Selection.Item(ir, 1))) If l < 3 Then GoTo NextRow For im = 2 To l If Mid(checkx, im, 1) = "," Then GoTo NextRow If Mid(checkx, im, 1) = " " Then iMax = im Next im If iMax > 0 Then Selection.Item(ir, 1) = Trim(Mid(checkx, iMax, l - iMax + 1)) & ", " & Trim(Left(checkx, iMax)) End If NextRow: Next ir terminated: '--Application.ScreenUpdating = True End Sub 'LastName Function LastNameF(FullName As String) As String 'modified from Myrna Larsen 2000-05-01 programming 'must be a comma before titles like II, III, Jr, Sr, Dr ' i.e. Leroy Smith, III Dim CommaPos As Long Dim Start As Long Dim NextSpace As Long 'find the comma; if there isn't one, treat as though 'there is a comma appended to the name, e.g. John Jones, CommaPos = InStr(FullName, ",") If CommaPos = 0 Then CommaPos = Len(FullName) + 1 'find the last space before the comma NextSpace = 0 Do Start = NextSpace + 1 NextSpace = InStr(Start, FullName, " ") Loop While NextSpace > 0 And NextSpace < CommaPos LastNameF = Mid$(FullName, Start, CommaPos - Start) _ & ", " & Left(FullName, Start - 2) & _ Right(FullName, Len(FullName) - CommaPos) End Function Sub FirstName() 'David McRitchie 2000-03-23 programming 'http://www.mvps.org/dmcritchie/excel/join.htm#firstname Application.ScreenUpdating = False Application.Calculation = xlManual Dim cell As Range Dim cPos As Long Dim origcell As Variant For Each cell In Selection.SpecialCells(xlConstants, xlTextValues) cPos = InStr(1, cell, ",") If cPos > 1 Then origcell = cell.Value cell.Value = Trim(Mid(cell, cPos + 1)) & " " _ & Trim(Left(cell, cPos - 1)) End If Next cell Application.Calculation = xlAutomatic 'xlCalculationAutomatic Application.ScreenUpdating = False End Sub Sub FixUSzip5() 'David McRitchie 2000-04-28 notposted, updated 2001-12-14 'http://www.mvps.org/dmcritchie/excel/join.htm#fixuszips Application.ScreenUpdating = False Application.Calculation = xlManual Dim cell As Range Dim cValue Dim cPos As Long Selection.Replace What:=Chr(160), replacement:=Chr(32), _ lookat:=xlPart, SearchOrder:=xlByRows, MatchCase:=False 'Trim in Excel removes extra internal spaces, VBA does not On Error Resume Next For Each cell In Selection.SpecialCells(xlConstants, 2) 'trim text cells cell.Value = Application.Trim(cell.Value) Next cell For Each cell In Selection.SpecialCells(xlCellTypeConstants, 1) 'special modification to also use 3 digits as if valid If Len(cell) = 4 Or Len(cell) = 5 Or Len(cell) = 3 Then cValue = cell.Value cell.NumberFormat = "@" cell.Value = Right("00000" & CStr(cell.Value), 5) End If Next cell Application.Calculation = xlAutomatic 'xlCalculationAutomatic Application.ScreenUpdating = False End Sub Sub FixCANADAzips() 'David McRitchie 2004-11-02 notposted, updated 'http://www.mvps.org/dmcritchie/excel/join.htm#fixuszips 'you might want to run TRIMALL macro before this macro Application.ScreenUpdating = False Application.Calculation = xlManual Dim cell As Range, str As String Selection.Replace What:=Chr(160), replacement:=Chr(32), _ lookat:=xlPart, SearchOrder:=xlByRows, MatchCase:=False 'Trim in Excel removes extra internal spaces, VBA does not On Error Resume Next For Each cell In Selection.SpecialCells(xlConstants, 2) 'you might want to run TRIMALL macro before this macro If cell Like "[A-Z]#[A-Z]#[A-Z]#" Then cell.Value = Left(cell.Value, 3) & " " & Mid(cell.Value, 4) End If Next cell Application.Calculation = xlAutomatic Application.ScreenUpdating = True End Sub Sub Force_TextDigits_6() Dim cell As Range 'DMcRitchie 2004-05-06 On Error Resume Next 'in case nothing found Application.ScreenUpdating = False Application.Calculation = xlManual For Each cell In Intersect(Selection, _ Selection.SpecialCells(xlConstants, xlNumbers)) cell.NumberFormat = "@" cell.Value = Format(cell.Value, "000000") Next cell Application.Calculation = xlAutomatic Application.ScreenUpdating = False End Sub Sub Fix_PhoneAreaCode() Dim cell As Range On Error Resume Next 'in case nothing found Dim AreaCode As String AreaCode = "412" AreaCode = InputBox("Supply your local area code " & _ "to be prefixed to phone numbers without an area code" _ & Chr(10) & " i.e. " & AreaCode _ & " will prefix current entries with ""(" & _ AreaCode & ") """, "Supply Area Code", AreaCode) If AreaCode = "" Then Exit Sub AreaCode = "(" & AreaCode & ") " For Each cell In Intersect(Selection, _ Selection.SpecialCells(xlConstants, xlTextValues)) If Len(cell) = 8 Then 'as in 555-1212 cell.Value = AreaCode & Trim(cell.Value) End If Next cell 'On Error Resume Next -- continues in effect For Each cell In Intersect(Selection, _ Selection.SpecialCells(xlConstants, xlNumbers)) If cell > 999999 And cell < 9999999 Then cell.Value = AreaCode & Format(cell.Value, "000-0000") End If Next cell End Sub 'Public Function Mirror(aRange As Range) 'Tushar Mehta microsoft.public.Excel.misc 2000-07-28 If aRange.Cells.Count > 1 Then Mirror = "Only one cell please" Mirror = strReverse(aRange.Text) End Function Sub SQUOTE_add() 'David McRitchie 2000-08-05 notposted 'http://www.mvps.org/dmcritchie/excel/join.htm#squote Application.ScreenUpdating = False Application.Calculation = xlManual Dim cell As Range For Each cell In Intersect(Selection, ActiveSheet.UsedRange) If Len(Trim(cell)) > 0 Then _ If Left(cell.Formula) = "=" Then cell.Value = "'" & cell.Formula Next cell Application.Calculation = xlAutomatic 'xlCalculationAutomatic Application.ScreenUpdating = False End Sub Sub SQUOTE_remove() 'David McRitchie 2000-08-05 notposted 'http://www.mvps.org/dmcritchie/excel/join.htm#squote Application.ScreenUpdating = False Application.Calculation = xlManual Dim cell As Range For Each cell In Intersect(Selection, ActiveSheet.UsedRange) If VarType(cell) = 8 Then cell.Formula = cell.Formula 'note the squote is not easily detectable Next cell Application.Calculation = xlAutomatic 'xlCalculationAutomatic Application.ScreenUpdating = False End Sub Sub Make_INDIRECT() 'David McRitchie 2000-10-12 notposted 'http://www.mvps.org/dmcritchie/excel/join.htm#indirect Application.ScreenUpdating = False Application.Calculation = xlManual Dim cell As Range ' On Error Resume Next For Each cell In Intersect(Selection, ActiveSheet.UsedRange) If Left(cell.Formula & " ", 1) = "=" Then If Left(cell.Formula, 10) <> "=INDIRECT(" Then If InStr(1, cell.Formula, "!", 0) Then If InStr(1, LCase(cell.Formula), "getformula", 0) = 0 Then cell.Formula = "=indirect(""" & _ Mid(Replace(cell.Formula, """", """"""), 2, 9999) & """)" End If End If End If End If Next cell Application.Calculation = xlAutomatic 'xlCalculationAutomatic Application.ScreenUpdating = False End Sub Sub FillEmpty() 'Tom Ogilvy, 1999/12/14 programming ' Revised David McRitchie, 2000-11-25 programming Application.ScreenUpdating = False Application.Calculation = xlManual Dim cell As Range For Each cell In Intersect(Selection, _ ActiveSheet.UsedRange) If Trim(cell) = "" And cell.Row > 1 Then cell.NumberFormat = cell.Offset(-1, 0).NumberFormat cell.Value = cell.Offset(-1, 0).Value End If Next cell Application.Calculation = xlAutomatic 'xlCalculationAutomatic Application.ScreenUpdating = False End Sub Sub Fill_Empty() '--David McRitchie, 2003-07-24, see fillhand.htm and join.htm '--Macro version of -- Excel -- Data Entry -- Fill Blank Cells '-- http://www.contextures.com/xlDataEntry02.html '-- http://www.pcworld.com/shared/printable_articles/0,1440,9346,00.html Dim oRng As Range Set oRng = Selection Selection.Font.Bold = True Selection.SpecialCells(xlCellTypeBlanks).Select Selection.Font.Bold = False Selection.FormulaR1C1 = "=R[-1]C" '-- remove the added fromulas oRng.Copy oRng.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _ False, Transpose:=False End Sub Sub DelRowsBelow() Range(ActiveCell.Row + 1 & ":" & 65536).Delete 'obsolete code don't hard code End Sub Sub A_Selected_Delete_Rows() Intersect(Selection, Range("A:A"), _ ActiveSheet.UsedRange).EntireRow.Delete End Sub Sub A_Selected_Insert_Rows() Intersect(Selection, Range("A:A"), _ ActiveSheet.UsedRange).EntireRow.Insert End Sub Sub AS_TEXT() 'DMcRitchie, code/join.txt, 2001-01-23, programming Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Dim Make_A_Break 'allow change while running On Error Resume Next 'In case no cells in selection Dim vString As String Dim cell As Range For Each cell In Intersect(Selection, ActiveSheet.UsedRange) vString = cell.Text cell.NumberFormat = "@" cell.Value = vString Make_A_Break = DoEvents 'yield to system tasks Next cell 'simplify formatting Selection.NumberFormat = "@" Application.Calculation = xlCalculationAutomatic Application.ScreenUpdating = True End Sub Sub CreateText() Selection.Copy Selection.NumberFormat = "@" Selection.PasteSpecial Paste:=xlText, Operation:=xlNone, SkipBlanks:= _ False, Transpose:=False End Sub Sub FillSequence() Dim cell As Range Dim I As Long For Each cell In Selection I = I + 1 cell.Value = I Next cell End Sub Sub MakeTrueDate() 'Converts Text Dates to dates (US), Tom Ogilvy, 2001-03-24 programming Dim rng As Range Set rng = Intersect(ActiveCell.EntireColumn, _ ActiveSheet.UsedRange) 'next assume first row is a header Set rng = rng.Offset(1, 0).Resize(rng.Rows.Count - 1) rng.NumberFormat = "mm/dd/yyyy" rng.Value = rng.Value End Sub Sub MakeFormulasFromText() Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Dim cell As Range On Error Resume Next 'In case no cells in selection For Each cell In Intersect(Selection, _ Selection.SpecialCells(xlConstants, xlTextValues)) If Left(cell.Value, 1) = "=" Then cell.Formula = cell.Value Next Application.Calculation = xlCalculationAutomatic Application.ScreenUpdating = True End Sub Sub MakeText() Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Dim cell As Range On Error Resume Next 'In case no cells in selection For Each cell In Intersect(Selection, ActiveSheet.UsedRange) cell.Formula = "'" & cell.Text Next Application.Calculation = xlCalculationAutomatic Application.ScreenUpdating = True End Sub Sub MakeValues() Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Dim cell As Range On Error Resume Next 'In case no cells in selection For Each cell In Intersect(Selection, _ Selection.SpecialCells(xlFormulas)) cell.Value = cell.Value Next Application.Calculation = xlCalculationAutomatic Application.ScreenUpdating = True End Sub Sub S_active() 'select only cells in selection matching activecell value Dim cell As Range 'posted D.McRitchie Dim I As Long 'in programming 2001-04-04 Dim sStr As String For Each cell In Intersect(Selection, _ Selection.SpecialCells(xlConstants, xlTextValues)) I = I + 1 If cell.Value = ActiveCell.Value Then _ sStr = sStr & "," & cell.Address(0, 0) _ & ":" & cell.Address(0, 0) Next cell [A1] = sStr Range(Mid(sStr, 2, Len(sStr) - 1)).Select End Sub Sub InsertCellReplacement() 'David McRitchie, misc, 2001-05-23 ' http://www.mvps.org/dmcritchie/excel/join.htm Dim cell As Range Dim V As String, vv As String Dim I As Long, j As Long V = "=HYPERLINK(""[ss.xls]'sheet7'!cell"",[ss.xls]sheet7!cell)" V = InputBox("oportunity to change your formula" _ & vbCr & "the word cell will be substituted with cell address", _ "Your call is important to us", V, vbOKCancel) If V = "" Then GoTo terminate For Each cell In Selection vv = V For I = 1 To 3 j = InStr(1, vv, "cell") If j = 0 Then GoTo vDone vv = Left(vv, j - 1) & cell.Address(1, 1) & Mid(vv, j + 4, 999) Next I vDone: cell.Formula = vv Next cell terminate: End Sub Sub Remove_Prefix() 'David McRitchie 2001-08-27 excel.programming 'prefix removal Application.ScreenUpdating = False Application.Calculation = xlCalculationManual 'pre XL97 xlManual Dim Temp As String Dim cell As Range Dim xPre As String xPre = InputBox("Supply Prefix to be removed:", _ "Prefix Removal", "401 1") If xPre = "" Then GoTo done On Error GoTo done For Each cell In Intersect(Selection, _ Selection.SpecialCells(xlCellTypeConstants, 2)) 'above limits to constants which are TEXT If Left(cell.Value, Len(xPre)) = xPre Then cell.Value = Mid(cell.Value, Len(xPre) + 1) End If Next done: Application.Calculation = xlCalculationAutomatic 'pre XL97 xlAutomatic Application.ScreenUpdating = True End Sub Function Before_Number(txtString) As String Dim I As Long I = 1 If Trim(txtString) = "" Then Before_Number = "" Exit Function End If For I = 1 To Len(txtString) If IsNumeric(Mid(txtString, I, 1)) Then GoTo done If Mid(txtString, I, 1) = "," Then GoTo done Next I done: Before_Number = Trim(Left(txtString, I - 1)) End Function Sub RemoveAllSpaces() 'David McRitchie 2000-10-24 Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Selection.SpecialCells(xlConstants).Replace What:=Chr(160), _ replacement:="", _ lookat:=xlPart, SearchOrder:=xlByColumns, MatchCase:=True Selection.SpecialCells(xlConstants).Replace What:=Chr(32), _ replacement:="", _ lookat:=xlPart, SearchOrder:=xlByColumns, MatchCase:=True Application.Calculation = xlCalculationAutomatic Application.ScreenUpdating = True End Sub Sub RemoveAllSpaces2() 'Remove all spaces from text constants, except on Row 1 'David McRitchie, 2002-08-27, 'http://www.mvps.org/dmcritchie/excel/join.htm#removeallspaces2 Dim rng As Range Set rng = Intersect(Selection, _ Cells.Rows("2:" & Cells.Rows.Count), _ Selection.SpecialCells(xlConstants, xlTextValues)) If rng Is Nothing Then Exit Sub Application.ScreenUpdating = False rng.Replace What:=Chr(160), replacement:="", _ lookat:=xlPart, SearchOrder:=xlByRows, MatchCase:=False rng.Replace What:=Chr(32), replacement:="", _ lookat:=xlPart, SearchOrder:=xlByRows, MatchCase:=False Application.ScreenUpdating = True End Sub Sub TrimALL() 'David McRitchie 2000-07-03 mod 2002-08-16 2005-09-29 join.htm '-- http://www.mvps.org/dmcritchie/excel/join.htm#trimall ' - Optionally reenable improperly terminated Change Event macros Application.DisplayAlerts = True Application.EnableEvents = True 'should be part of Change Event macro If Application.Calculation = xlCalculationManual Then MsgBox "Calculation was OFF will be turned ON upon completion" End If Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Dim cell As Range 'Also Treat CHR 0160, as a space (CHR 032) Selection.Replace What:=Chr(160), replacement:=Chr(32), _ lookat:=xlPart, SearchOrder:=xlByRows, MatchCase:=False Selection.Replace What:=Chr(13) & Chr(10), replacement:=Chr(32), _ lookat:=xlPart, SearchOrder:=xlByRows, MatchCase:=False Selection.Replace What:=Chr(13), replacement:=Chr(32), _ lookat:=xlPart, SearchOrder:=xlByRows, MatchCase:=False Selection.Replace What:=Chr(21), replacement:=Chr(32), _ lookat:=xlPart, SearchOrder:=xlByRows, MatchCase:=False '--------------------------- Selection.Replace What:=Chr(8), replacement:=Chr(32), _ lookat:=xlPart, SearchOrder:=xlByRows, MatchCase:=False Selection.Replace What:=Chr(9), replacement:=Chr(32), _ lookat:=xlPart, SearchOrder:=xlByRows, MatchCase:=False 'Trim in Excel removes extra internal spaces, VBA does not On Error Resume Next For Each cell In Intersect(Selection, _ Selection.SpecialCells(xlConstants, xlTextValues)) cell.Value = Application.Trim(cell.Value) Next cell On Error GoTo 0 Application.Calculation = xlCalculationAutomatic Application.ScreenUpdating = True End Sub Sub TrimALL_alternate() 'Dave Peterson, worksheet.functions, 2002-08-17 'see http://www.mvps.org/dmcritchie/join.htm#trimall 'http://google.com/groups?as_umsgid=3D5EEE8D.601CB075@msn.com Dim myRange As Range Dim myCol As Range Set myRange = Intersect(ActiveSheet.UsedRange, Selection) If myRange Is Nothing Then Exit Sub Application.ScreenUpdating = False myRange.Replace What:=Chr(160), replacement:=Chr(32), _ lookat:=xlPart, SearchOrder:=xlByRows, MatchCase:=False For Each myCol In myRange.Columns If Application.CountA(myCol) > 0 Then myCol.TextToColumns Destination:=myCol(1), _ DataType:=xlFixedWidth, FieldInfo:=Array(0, 1) End If Next myCol Application.ScreenUpdating = True End Sub Sub TrimALL_for_all_Sheets() 'D.McRitchie, 2005-07-30, excel.newusers Dim sht As Worksheet, RC As Long, rng As Range RC = MsgBox("Are you sure you want to run TrimALL " _ & "on an Entire Workbook", vbYesNo) If RC <> vbYes Then MsgBox "Thank you, your data will not be touched, by your command" Exit Sub End If For Each sht In Sheets Sheets(sht.Name).Select Set rng = Selection Cells.Select TrimALL rng.Select Next sht End Sub Sub AsText() 'David McRitchie 2000-07-03 mod 2002-08-16 join.htm Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Dim cell As Range 'Also Treat CHR 0160, as a space (CHR 032) Selection.Replace What:=Chr(160), replacement:=Chr(32), _ lookat:=xlPart, SearchOrder:=xlByRows, MatchCase:=False Selection.Replace What:=Chr(13) & Chr(10), replacement:=Chr(32), _ lookat:=xlPart, SearchOrder:=xlByRows, MatchCase:=False Selection.Replace What:=Chr(13), replacement:=Chr(32), _ lookat:=xlPart, SearchOrder:=xlByRows, MatchCase:=False Selection.Replace What:=Chr(21), replacement:=Chr(32), _ lookat:=xlPart, SearchOrder:=xlByRows, MatchCase:=False 'Trim in Excel removes extra internal spaces, VBA does not On Error Resume Next For Each cell In Intersect(Selection, ActiveSheet.UsedRange) cell.Value = "'" & Application.Trim(cell.Text) Next cell On Error GoTo 0 Application.Calculation = xlCalculationAutomatic Application.ScreenUpdating = True End Sub Sub TrimSUB() 'David McRitchie mod.2000-09-28 programming 'VBA TRIM removes only lead/trailing spaces, 'Application.TRIM also removes multi & internal spaces Application.Calculation = xlCalculationManual Application.ScreenUpdating = False Dim iCell As Range On Error Resume Next For Each iCell In Intersect(Selection, _ Selection.SpecialCells(xlConstants, xlTextValues)) iCell.Value = Application.Trim(iCell.Value) Next iCell Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic End Sub Sub RequireChar() 'David McRitchie 2002-09-04 not documented Dim search4 As String Dim I As Long search4 = "Cached" If Selection.Columns.Count <> 1 Then MsgBox "select only one column, rows without search" _ & " element will be deleted" Exit Sub End If search4 = InputBox("supply required character(s) to preserve " _ & "row content", "Required Chars", search4) ActiveSheet.Copy After:=ActiveSheet Application.Calculation = xlCalculationManual Application.ScreenUpdating = False For I = Selection.Count To 1 Step -1 If InStr(1, Selection(I).Value, search4) = 0 Then Selection(I).EntireRow.Delete End If If Mid(Trim(Selection(I).Value), 1, 7) <> "http://" Then Selection(I) = "http://" & Trim(Selection(I).Value) End If Next I Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic End Sub Sub UnMerge() Selection.MergeCells = False End Sub Function BeforeFirstCap(Word) Dim I As Long For I = 1 To Len(Word) If Mid(Word, I, 1) >= "A" And Mid(Word, I, 1) <= "Z" Then BeforeFirstCap = Trim(Left(Word, I - 1)) Exit Function End If Next I BeforeFirstCap = Trim(Word) End Function Sub ID_Suffix() '-- http://www.mvps.org/dmcritchie/code/join.txt 2003-06-06 WF '-- http://google.com/groups?threadm=O9d%23JrDLDHA.2236@TK2MSFTNGP09.phx.gbl Dim StrOut As String, strcnt As Long, SuffixStr As String Dim l As Long, TxtCnt As Long SuffixStr = InputBox("Supply suffix string for counting," _ & Chr(10) & "Default is a single space", _ "Supply suffix string", " ") If SuffixStr = "" Then Exit Sub l = Len(SuffixStr) TxtCnt = 0 Application.Calculation = xlCalculationManual Application.ScreenUpdating = False Dim cell As Range On Error Resume Next TxtCnt = Intersect(Selection, _ Selection.SpecialCells(xlConstants, xlTextValues)).Count For Each cell In Intersect(Selection, _ Selection.SpecialCells(xlConstants, xlTextValues)) If Right(cell.Value, l) = SuffixStr Then StrOut = StrOut & Chr(10) & cell.Address(0, 0) strcnt = strcnt + 1 End If Next cell ' On Error GoTo 0 MsgBox "Found " & strcnt & " occurences of """ & _ SuffixStr & """, there are " & _ TxtCnt & " text cells in your selection, found" _ & StrOut Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic End Sub Sub ReenterAsText() 'David McRitchie 2003-08-07 may or may not be documented in ' http://www.mvps.org/dmcritchie/excel/join.htm 'purpose to prepare data for xl2html conversion ' On Error Resume Next Dim I As Long, str As String Application.Calculation = xlCalculationManual Application.ScreenUpdating = True For I = Selection.Count To 1 Step -1 str = Selection.Item(I).Text str = Replace(str, Chr(32), Chr(160)) Selection.Item(I).Value = str Next I Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic End Sub Sub Numbers_to_Text() 'David McRitchie 2006-01-13 'Format the selection as text beforehand, this ' macro will convert any numeric constant to a ' trimmed text version, and leave text constants as is. Dim rng As Range, cell As Range Set rng = Intersect(Selection, _ Selection.SpecialCells(xlCellTypeConstants, xlNumbers)) If rng Is Nothing Then Exit Sub Application.Calculation = xlCalculationManual Application.ScreenUpdating = True For Each cell In rng cell.Formula = Trim(cell.Text) Next cell Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic End Sub Function textstr(cell As Range) As String textstr = cell.Text End Function Function Reverse(cell As Range) As String Reverse = strReverse(cell) End Function Function ReverseT(cell As Range) As String ReverseT = strReverse(cell.Text) End Function Sub SepColumnOnLF() '-- if you have multiple LF in cells insert more columns and loop the LF Application.ScreenUpdating = False Application.Calculation = xlCalculationManual '-- insert column to right of active cell, before separations Dim cell As Range, I As Long ActiveCell.Offset(0, 1).EntireColumn.Insert For Each cell In Intersect(ActiveCell.EntireColumn, _ Selection.SpecialCells(xlConstants, xlTextValues)) I = InStr(1, cell.Value, Chr(10)) If I <> 0 Then cell.Offset(0, 1).Value = Mid(cell.Value, I + 1) cell.Value = Left(cell.Value, I - 1) End If Next cell Application.Calculation = xlCalculationAutomatic Application.ScreenUpdating = True End Sub Sub Convert_to_Values_in_Selection() '-- Selection.Copy Selection.PasteSpecial Paste:=xlPasteValues, _ Operation:=xlNone, SkipBlanks:=False, Transpose:=False ActiveSheet.Paste Application.CutCopyMode = False End Sub Sub Convert_to_Text_in_Selection() 'convert numeric cells to text ' leave it up to to format right if wanted ' or run TrimALL macro if wanted Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Dim cell As Range On Error Resume Next 'no cells found in selection For Each cell In _ Selection.SpecialCells(xlCellTypeFormulas, 1) cell.Value = cell.Text Next cell For Each cell In _ Selection.SpecialCells(xlCellTypeConstants, 1) cell.Value = cell.Text Next cell Application.Calculation = xlCalculationAutomatic Application.ScreenUpdating = True End Sub Sub Convert_Numeric_Constants_to_Text_in_Selection() 'convert cells with numeric constants to text ' leave it up to to format right if wanted ' or run TrimALL macro if wanted Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Dim cell As Range On Error Resume Next 'no cells found in selection For Each cell In _ Selection.SpecialCells(xlCellTypeConstants, 1) cell.Value = cell.Text Next cell Application.Calculation = xlCalculationAutomatic Application.ScreenUpdating = True End Sub