Option Explicit
Dim myRng As Range
Sub Get_Next_AvailableRow()
Set myRng = Range("a65536").End(xlUp).Offset(1, 0)
MsgBox myRng.Address
End Sub
Archive for August, 2008
Get Next Available Row on ActiveSheet
Create ShortCut Link at the desired location
Create ShortCut at the desired location.
Option Explicit
Sub MakeShortcut()
'//Need to refer to Windows Script Host Object Module
Dim WSH As New IWshRuntimeLibrary.IWshShell_Class
Dim WSHShortcut As IWshRuntimeLibrary.IWshShortcut_Class
Dim strPath As String
strPath = "\\aphydbanhllbsd\share\selva\Shortcut.lnk"
Set WSHShortcut = WSH.CreateShortcut(strPath)
With WSHShortcut
.TargetPath = "http://socko.wordpress.com"
.Description = "Description of shortcut"
' Location of Icon
.IconLocation = "%SystemRoot%\system32\SHELL32.dll,5"
.RelativePath = "c:\temp"
.WorkingDirectory = "c:\"
'Hot Key
.Hotkey = "Ctrl+Alt+Q"
.Save
End With
Next i
End Sub
Reduce Excel File Size
-Selva V Pasupathy, HSBC Global Resourcing, Hyderabad1
Option Explicit
' Written by Selva V Pasupathy
' You are free to use the code and make changes
' contact me at selvavinaygam (at) GMail (dot) com
Dim j As Long
Dim k As Long
Dim lRow As Long
Dim lCol As Long
Dim cFormula As Range
Dim rFormula As Range
Dim cValue As Range
Dim rValue As Range
Dim myShape As Shape
Dim mySheet As Worksheet
Sub ExcelDiet()
On Error Resume Next
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For Each mySheet In Worksheets
With mySheet
On Error Resume Next
Set cFormula = .Cells.Find(What:="*", _
After:=Range("A1"), LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious)
Set cValue = .Cells.Find(What:="*", _
After:=Range("A1"), LookIn:=xlValues, _
LookAt:=xlPart, SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious)
Set rFormula = .Cells.Find(What:="*", _
After:=Range("A1"), LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRomySheet, _
SearchDirection:=xlPrevious)
Set rValue = .Cells.Find(What:="*", _
After:=Range("A1"), LookIn:=xlValues, _
LookAt:=xlPart, SearchOrder:=xlByRomySheet, _
SearchDirection:=xlPrevious)
On Error GoTo 0
If cFormula Is Nothing Then
lCol = 0
Else
lCol = cFormula.Column
End If
If Not cValue Is Nothing Then
lCol = Application.WorksheetFunction. _
Max(lCol, cValue.Column)
End If
If rFormula Is Nothing Then
lRow = 0
Else
lRow = rFormula.Row
End If
If Not rValue Is Nothing Then
lRow = Application.WorksheetFunction. _
Max(lRow, rValue.Row)
End If
For Each myShape In .Shapes
j = 0
k = 0
On Error Resume Next
j = myShape.TopLeftCell.Row
k = myShape.TopLeftCell.Column
On Error GoTo 0
If j > 0 And k > 0 Then
Do Until .Cells(j, k).Top > _
myShape.Top + myShape.Height
j = j + 1
Loop
If j > lRow Then
lRow = j
End If
Do Until .Cells(j, k).Left > _
myShape.Left + myShape.Width
k = k + 1
Loop
If k > lCol Then
lCol = k
End If
End If
Next
.Range(Cells(1, lCol + 1).Address & ":IV65536").Delete
.Range(Cells(lRow + 1, 1).Address & ":IV65536").Delete
End With
Next
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
ADODB Connection Module
Save Connection Procedures & functions in a public module that helps simplify the connection procedures.
-Selva V Pasupathy, HSBC Global Resourcing, Hyderabad
Option Explicit
Public i, j, k As Integer
Public objConn As New ADODB.Connection
Public objrs As New ADODB.Recordset
Public strConn, dbSource, strSQL As String
Sub Get_Connection()
Set objConn = New ADODB.Connection
strConn = "Provider=Microsoft.Jet.OLEDB.4.0; " & _
"Data Source='" & BrowseFileName & "'"
objConn.Open strConn
End Sub
Sub Get_RecordSet(ByRef strSQL As String)
Set objrs = New ADODB.Recordset
objrs.Open strSQL, objConn, adOpenStatic, adLockOptimistic
End Sub
Public Function BrowseFileName() As String
Dim dlgOpen As FileDialog
Dim name As String, fileName As String, target As String
Dim lngIndex As Long
Set dlgOpen = Application.FileDialog(msoFileDialogOpen)
With dlgOpen
.AllowMultiSelect = True
.Show
BrowseFileName = .SelectedItems(1)
End With
End Function
Remove Unprintable Character & Spaces from cells
There are times when you get text that has unprintable characters in them or extra spaces, typically from downloaded data or perhaps extracted data. This routine cleans your selected cells of thes characters.
-Selva V Pasupathy, HSBC Global Resources, Hyderabad.
Original Source: Ivan F Moala’s Site http://www.xcelfiles.com/VBA_Quick10.html
Option Explicit
Sub Clean_Trim()
‘// From Help Files:
‘// CLEAN > Removes all nonprintable characters from text.
‘// Use CLEAN on text imported from other applications that
‘// contains characters that may not print with your
‘// operating system.
‘// For example, you can use CLEAN to remove some low-level
‘// computer code that is frequently at the beginning and end
‘// of data files and cannot be printed.
‘// TRIM > Removes all spaces from text except for single
‘// spaces between words. Use TRIM on text that you have
‘// received from another application that may
‘// have irregular spacing.
Dim CleanTrimRg As Range
Dim oCell As Range
Dim Func As WorksheetFunction
Set Func = Application.WorksheetFunction
On Error Resume Next
Set CleanTrimRg = Selection.SpecialCells(xlCellTypeConstants, 2)
If Err Then MsgBox “No data to clean and Trim!”: Exit Sub
For Each oCell In CleanTrimRg
oCell = Func.Clean(Func.Trim(oCell))
Next
End Sub
Add an Image to Cell Comments
Add a bit of spice to your comments look by adding an Image file.
See results below.
Supported image file formats = .bmp; .gif; .tif; .jpg
-Selva V Pasupathy, HSBC Global Resourcing, Hyderabad
(Original Source: by Ivan Moala’s Site: http://www.xcelfiles.com/ )
Option Explicit
Const ImgFileFormat = "Image Files (*.bmp;*.gif;*.tif;*.jpg;*.jpeg)," & _
"*bmp;*gif;*.tif;*.jpg;*.jpeg"
Sub AddPicturesToComments()
Dim HasCom
Dim Pict As String
Dim Ans As Integer
Set HasCom = ActiveCell.Comment
If Not HasCom Is Nothing Then ActiveCell.Comment.Delete
Set HasCom = Nothing
GetPict:
Pict = Application.GetOpenFilename(ImgFileFormat)
'Note you can load in, almost any file format
If Pict = "False" Then End
Ans = MsgBox("Open : " & Pict, vbYesNo + vbExclamation, "Use this Picture?")
If Ans = vbNo Then GoTo GetPict
With ActiveCell
.AddComment
.Comment.Visible = False
.Comment.Shape.Fill.Transparency = 0#
.Comment.Shape.Fill.UserPicture Pict
End With
End Sub
Write to & Read from Sequential Text Files
-Selva V Pasupathy, HSBC Global Resourcing, Hyderabad
Option Explicit
Dim Racf(5) As String
Private i, j, k As Integer
Private nFile As Integer
Private str, FileContent As String
Private Const FileName = "\\aphydbanhllbsd\share\Selva\WordPressLogin.vbs"
Private Sub Write_Text2Combo()
Ref_ArrVariable
nFile = FreeFile
Open FileName For Output As #nFile
For i = 0 To 5
Print #nFile, Racf(i)
Next
Close #nFile
End Sub
Private Sub Read_Text2Combo()
nFile = FreeFile
Open FileName For Input As #nFile
Do Until EOF(nFile)
Line Input #nFile, str
FileContent = FileContent & vbNewLine & str
Loop
MsgBox FileContent
Close #nFile
End Sub
