PAste value only for Ctrl -V

In this workboook:

Private Sub Workbook_Open()

Application.OnKey "^v", "DoMyPaste"

End Sub

In module :

Public Sub DoMyPaste()

On Error Resume Next

ActiveSheet.PasteSpecial Format:=Text, Link:=False, DisplayAsIcon:=False

Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False

End Sub

Excel Paste Value only

http://www.mrexcel.com/archive/VBA/4522.html

perl 2 array

my @num = qw (1 2 3 4 5); my @alp = qw (A B C D E); #One way for my $index (0 .. $#num) { print "$num[$index]-$alp[$index]\n"; } #Or print "$num[$_]-$alp[$_]\n" for (0 .. $#num);

file and dirhandle for perl

($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,

$atime,$mtime,$ctime,$blksize,$blocks)

= stat($filename);

http://perldoc.perl.org/functions/stat.html

@files = ;

Or if you just want a list of the files with the extension .html:

@files = ;

-e File exists.

-z File has zero size (is empty).

-s File has nonzero size (returns size in bytes).

-f File is a plain file.

-d File is a directory.

-l File is a symbolic link.

Private Sub Worksheet_Change(ByVal Target As Excel.Range)

If Application.CutCopyMode = False Then Exit Sub

Application.EnableEvents = False

Application.Undo

Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _

False, Transpose:=False

Application.EnableEvents = True

End Sub

method1:

sub PasteValues()

' Keyboard Shortcut: Ctrl+v

On Error Resume Next

Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False

Application.CutCopyMode = False

End Sub

Sub Auto_Open()

Application.CommandBars("Cell").Reset

With Application.CommandBars("Cell")

.Controls("Paste").OnAction = "PasteValues" ' Changes right click cell paste to use Pastevalues macro

.Controls(4).Delete ' removes paste secial option

End With

Application.CommandBars("Row").Reset

With Application.CommandBars("Row")

.Controls("Paste").OnAction = "PasteValues" ' Changes right click row paste to use Pastevalues macro

.Controls(4).Delete ' removes paste secial option

End With

Application.CommandBars("Column").Reset

With Application.CommandBars("Column")

.Controls("Paste").OnAction = "PasteValues" ' Changes right click column paste to use Pastevalues macro

.Controls(4).Delete ' removes paste secial option

End With

Application.CommandBars("Worksheet Menu Bar").Reset

With Application.CommandBars("Worksheet Menu Bar").Controls

.Item(2).Controls(6).OnAction = "PasteValues" ' changes edit/paste to use Pastevalues macro

.Item(2).Controls(7).Enabled = False ' disable paste special

End With

Application.CommandBars("Standard").Reset

With Application.CommandBars("Standard").Controls.Item(12)

.Enabled = False

End With

End Sub

2.http://www.rondebruin.nl/values.htm

macro vba, remove all merge cell

Option Explicit

Sub Unmerge_CenterAcross()

'Erik Van Geit

'080808

'merged cells will be unmerged

'contents will be centered across merged area

Dim LR As Long 'Last Row

Dim LC As Integer 'Last Column

Dim i As Long

Dim j As Long

Dim cntUnmerged As Long

Dim cntMerged As Long

Dim mergeRng As Range

Dim checkmerged As Boolean

Dim LastMerged As String

Dim AppSetCalc As Integer

Dim StatusBarVisible As Boolean

Dim msg As String

Dim MaxRc As Long

Dim ColorMe As Boolean

If ActiveWorkbook.Saved = False Then

msg = "Your workbook is not saved." & vbNewLine

msg = msg & "Code checks last used cell, which is only updated when saved" & vbNewLine & vbNewLine

msg = msg & "Do want to save now?"

If MsgBox(msg, 292, "SAVE?") = vbYes Then

On Error Resume Next

ActiveWorkbook.Save

If Err Then

MsgBox Err.Description, vbCritical, "ERROR " & Err.Number

Exit Sub

End If

End If

End If

With ActiveSheet

'needing xlCellTypeLastCell: else if last cell is merged wrong area will be found

LR = .Cells.SpecialCells(xlCellTypeLastCell).Row

LC = .Cells.SpecialCells(xlCellTypeLastCell).Column

With .Cells(LR, LC)

If .MergeCells Then

LR = LR + .MergeArea.Rows.Count - 1

LC = LC + .MergeArea.Columns.Count - 1

End If

End With

If .Range(.Cells(1, 1), .Cells(LR, LC)).MergeCells = False Then

MsgBox "no merged cells on this sheet", 48, "EXIT"

Exit Sub

End If

msg = "Please define max # of rows a merged area may contain"

msg = msg & "EXAMPLE" & vbNewLine & "If you type ""5"" then A1:A5 or A1:B5 will be unmerged, but not A1:A6"

MaxRc = Application.InputBox(msg, "", 1, , , , , 1)

If MaxRc = 0 Then Exit Sub

msg = "Do you want to color the unmerged cells to check out the result?"

ColorMe = MsgBox(msg, 292, "Color") = vbYes

With Application

.ScreenUpdating = False

AppSetCalc = .Calculation

.Calculation = xlCalculationManual

StatusBarVisible = .DisplayStatusBar

.DisplayStatusBar = True

.EnableCancelKey = xlErrorHandler

End With

For i = 1 To LR

On Error Resume Next

checkmerged = .Range(.Cells(i, 1), .Cells(i, LC)).MergeCells

'error occurs when MergeArea intersects row and contains more rows

'checkmerged is TRUE when MergeArea is in one row

If Err Or checkmerged Then

Err.Clear

For j = 1 To LC

With .Cells(i, j)

If .Resize(1, 1).MergeCells Then

cntMerged = cntMerged + 1

On Error GoTo stopit

With .MergeArea

If .Rows.Count <= MaxRc Then

cntUnmerged = cntUnmerged + 1

.Unmerge

.HorizontalAlignment = xlCenterAcrossSelection

If ColorMe Then .Interior.ColorIndex = 3

Else

LastMerged = .Address(0, 0)

End If

End With

End If

End With

Next j

End If

Application.StatusBar = "rows checked: " & Round(i / LR, 2) * 100 & "%"

Next i

End With

stopit:

With Application

.EnableCancelKey = xlDisabled

.ScreenUpdating = True

.Calculation = AppSetCalc

.StatusBar = False

.DisplayStatusBar = StatusBarVisible

End With

If i > 0 Then

msg = IIf(i = LR + 1, "All rows checked", "Last row checked: " & vbTab & i) & vbNewLine

msg = msg & "Found areas: " & vbTab & cntMerged & vbNewLine

msg = msg & "Unmerged areas: " & vbTab & cntUnmerged & vbNewLine

If cntMerged <> cntUnmerged Then

msg = msg & "Still merged: " & vbTab & cntMerged - cntUnmerged & vbNewLine & vbNewLine

msg = msg & "Last area: " & LastMerged

End If

End If

If Err Then msg = msg & Err.Description

MsgBox msg, IIf(Err, vbCritical, vbOKOnly), IIf(Err, "ERROR " & Err.Number, "Done")

End Sub

merge cell vba macro

ActiveCell.Offset(1, 0).Select

Range(ActiveCell.Offset(0, 0), ActiveCell.Offset(0, 1)).Merge

ActiveCell.Select

-----------------------------------------------------

Dim foundFirst As Range

Dim foundOne As Range

Dim dataRRay As Variant

Dim searchIn As Range

Dim searchFor As String

Dim columnTo As Integer

columnTo = 8

searchFor = "table"

Set searchIn = Range("a:d")

Set searchIn = Application.Intersect(searchIn.Parent.UsedRange, searchIn)

ReDim dataRRay(0 To searchIn.Count)

Dim i As Long

i = 1

Set foundFirst = searchIn.Find(What:="*" & searchFor & "*", after:=searchIn.Range("a1"), _

LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, _

SearchDirection:=xlNext, MatchCase:=False)

Set foundOne = foundFirst

Do

dataRRay(i) = foundOne.Value

i = i + 1

Set foundOne = searchIn.Cells.FindNext(after:=foundOne)

Loop Until foundOne.Address = foundFirst.Address

dataRRay(0) = dataRRay(i - 1)

ReDim Preserve dataRRay(i - 2)

With Sheets("destinationSheet")

Range(.Cells(1, columnTo), .Cells(i - 1, columnTo)) = Application.Transpose(dataRRay)

End With

PAste value but not paste special

Private Sub Workbook_WindowActivate(ByVal Wn As Excel.Window)

Application.CommandBars("Edit").Controls.Item("Paste").OnAction = "New_paste"

Application.CommandBars("Cell").Controls.Item("Paste").OnAction = "New_paste"

End Sub

Private Sub Workbook_WindowDeactivate(ByVal Wn As Excel.Window)

Application.CommandBars(1).Reset

End Sub

Sub New_paste()

ActiveCell.PasteSpecial XlValues

End Sub

Delete hidden rows

Sub DeleteHiddenRows_Workbook()

'This Microsoft Excel Macro will remove hidden rows from
'all worksheets in a workbook.

For i = 1 To Worksheets.Count
If Worksheets(i).Visible Then
Worksheets(i).Select
ActiveCell.SpecialCells(xlLastCell).Select
k = ActiveCell.Row
For j = 1 To k
If Rows(j).Hidden Then
Rows(j).Hidden = False
Rows(j).Delete
End If
Next j
End If
Next i
If Worksheets(1).Visible Then Worksheets(1).Select

End Sub

determine row/ column is hidden

Range(“A1″).ColumnWidth = 0 Or Range(“A1″).RowHeight = 0
Range(“A1″).EntireColumn.Hidden Or Range(“A1″).EntireRow.Hidden

Prevent user from delete worksheet

method 1:

Private Sub Worksheet_Activate()

Dim Ctrl As Office.CommandBarControl

For Each Ctrl In Application.CommandBars.FindControls(ID:=847)

Ctrl.Enabled = False

Next Ctrl

End Sub

Private Sub Worksheet_Deactivate()

Dim Ctrl As Office.CommandBarControl

For Each Ctrl In Application.CommandBars.FindControls(ID:=847)

Ctrl.Enabled = True

Next Ctrl

End Sub

----------------------------------------------------------------------------------------------------------------

Method 2:

Option Explicit

Private Sub Workbook_Activate()

Call Workbook_SheetActivate(ActiveSheet)

End Sub

Private Sub Workbook_Deactivate()

Call Indel

End Sub

Private Sub Workbook_SheetActivate(ByVal Sh As Object)

Dim ws As Worksheet

For Each ws In ThisWorkbook.Worksheets

If ActiveSheet.Name = ("Data") _

Or ActiveSheet.Name = ("Query") _

Or ActiveSheet.Name = ("Sheet1") Then

Outdel

Else

Indel

End If

Next ws

End Sub

Private Sub Outdel()

Dim Ctrl As Office.CommandBarControl

For Each Ctrl In Application.CommandBars.FindControls(ID:=847)

Ctrl.Enabled = False

Next Ctrl

End Sub

Private Sub Indel()

Dim Ctrl As Office.CommandBarControl

For Each Ctrl In Application.CommandBars.FindControls(ID:=847)

Ctrl.Enabled = True

Next Ctrl

End Sub

----------------------------------------------------------------------------------------------------------------

Method 3:

Private Sub Worksheet_Activate()

Dim CB As CommandBar

Dim Ctrl As CommandBarControl

For Each CB In Application.CommandBars

Set Ctrl = CB.FindControl(ID:=847, recursive:=True)

If Not Ctrl Is Nothing Then

Ctrl.OnAction = "RefuseToDelete"

Ctrl.State = msoButtonUp

End If

Next

End Sub

Private Sub Worksheet_Deactivate()

Dim CB As CommandBar

Dim Ctrl As CommandBarControl

For Each CB In Application.CommandBars

Set Ctrl = CB.FindControl(ID:=847, recursive:=True)

If Not Ctrl Is Nothing Then Ctrl.OnAction = ""

Next

End Sub

Private Sub ResetDelete()

Dim CB As CommandBar

Dim Ctrl As CommandBarControl

For Each CB In Application.CommandBars

Set Ctrl = CB.FindControl(ID:=847, recursive:=True)

If Not Ctrl Is Nothing Then

Ctrl.Reset

Next CB

End Sub

'put in standard module

Public Sub RefuseToDelete()

MsgBox "This worksheet should not be deleted!", _

Buttons:=vbExclamation, _

Title:="Cannot Deleteworksheet!"

End Sub

Add-ins tab of the Ribbon

Sub CreateMenu()

' creates a new menu.

' can also be used to create commandbarbuttons

' may be automatically executed from an Auto_Open macro or a Workbook_Open eventmacro

Dim cbMenu As CommandBarControl, cbSubMenu As CommandBarControl

RemoveMenu ' delete the menu if it already exists

' create a new menu on an existing commandbar (the next 6 lines)

Set cbMenu = Application.CommandBars(1).Controls.Add(msoControlPopup, , , , True)

With cbMenu

.Caption = "&My menu"

.Tag = "MyTag"

.BeginGroup = False

End With

' alternatively, add to an existing menu (use the next line instead of the previous 6 lines)

'Set cbMenu = Application.CommandBars.FindControl(, 30007) ' Tools-menu

If cbMenu Is Nothing Then Exit Sub ' didn't find the menu...

' add menuitem to menu

With cbMenu.Controls.Add(msoControlButton, 1, , , True)

.Caption = "&Menu Item1"

.OnAction = ThisWorkbook.Name & "!TestMacro"

End With

' add menuitem to menu

With cbMenu.Controls.Add(msoControlButton, 1, , , True)

.Caption = "&Menu Item2"

.OnAction = ThisWorkbook.Name & "!TestMacro"

End With

' add a submenu

Set cbSubMenu = cbMenu.Controls.Add(msoControlPopup, 1, , , True)

With cbSubMenu

.Caption = "&Submenu1"

.Tag = "SubMenu1"

.BeginGroup = True

End With

' add menuitem to submenu (or buttons to a commandbar)

With cbSubMenu.Controls.Add(msoControlButton, 1, , , True)

.Caption = "&Submenu Item1"

.OnAction = ThisWorkbook.Name & "!TestMacro"

.Style = msoButtonIconAndCaption

.FaceId = 71

.State = msoButtonDown ' or msoButtonUp

End With

' add menuitem to submenu (or buttons to a commandbar)

With cbSubMenu.Controls.Add(msoControlButton, 1, , , True)

.Caption = "&Submenu Item2"

.OnAction = ThisWorkbook.Name & "!TestMacro"

.Style = msoButtonIconAndCaption

.FaceId = 72

.Enabled = False ' or True

End With

' add a submenu to the submenu

Set cbSubMenu = cbSubMenu.Controls.Add(msoControlPopup, 1, , , True)

With cbSubMenu

.Caption = "&Submenu2"

.Tag = "SubMenu2"

.BeginGroup = True

End With

' add menuitem to submenu submenu

With cbSubMenu.Controls.Add(msoControlButton, 1, , , True)

.Caption = "&Submenu Item1"

.OnAction = ThisWorkbook.Name & "!TestMacro"

.Style = msoButtonIconAndCaption

.FaceId = 71

.State = msoButtonDown ' or msoButtonUp

End With

' add menuitem to submenu submenu

With cbSubMenu.Controls.Add(msoControlButton, 1, , , True)

.Caption = "&Submenu Item2"

.OnAction = ThisWorkbook.Name & "!TestMacro"

.Style = msoButtonIconAndCaption

.FaceId = 72

.Enabled = False ' or True

End With

' add menuitem to menu

With cbMenu.Controls.Add(msoControlButton, 1, , , True)

.Caption = "&Remove this menu"

.OnAction = ThisWorkbook.Name & "!RemoveMenu"

.Style = msoButtonIconAndCaption

.FaceId = 463

.BeginGroup = True

End With

Set cbSubMenu = Nothing

Set cbMenu = Nothing

End Sub

Sub RemoveMenu()

' may be automatically executed from an Workbook_Close macro or

' a Workbook_BeforeClose eventmacro

DeleteCustomCommandBarControl "MyTag" ' deletes the new menu

End Sub

Private Sub DeleteCustomCommandBarControl(CustomControlTag As String)

' deletes ALL occurences of commandbar controls with a tag = CustomControlTag

On Error Resume Next

Do

Application.CommandBars.FindControl(, , CustomControlTag, False).Delete

Loop Until _

Application.CommandBars.FindControl(, , CustomControlTag, False) Is Nothing

On Error GoTo 0

End Sub

Sub TestMacro()

' used by the menuitems created by the CreateMenu macro

MsgBox "This would run your macro!", vbInformation, ThisWorkbook.Name

End Sub

find word funtion for macro vba

Option Explicit

Sub Format_Characters_In_Found_Cell()

Dim Found As Range, x As String, FoundFirst As Range

x = "over"

On Error Resume Next

Set Found = Cells.Find(what:=x, LookIn:=xlValues, LookAt:=xlPart)

If Not Found Is Nothing Then

Set FoundFirst = Found

Do

'Format from "x" to the end of the cell

Found.Characters(Start:=InStr(1, Found.Text, x), Length:=Len(Found)).Font.ColorIndex = 5

Set Found = Cells.FindNext(Found)

Loop Until FoundFirst.Address = Found.Address

Else

MsgBox x & " could not be found.", , " "

End If

End Sub

---------------------

What:="*a*b*" // provided a start 1st follow by keyword b

---------------------------------------------------------------------------------------------

References

http://www.excel-vba-easy.com/vba-programming-string-manipulation.html

http://www.pcreview.co.uk/forums/find-function-t2215904.html

http://www.mrexcel.com/forum/showthread.php?t=576407

search text in excel cell

myint=instr(1,activecell.value,"Abc")
which is going to return a number to where "Abc" starts

if myint > 0
text found.
----------------------------------------------------------------------
Function TextSearch(ByVal strSearchFor, ByVal Target As Variant) As Boolean
Dim OneCell As Range

TextSearch = False
If TypeName(Target) = "Range" Then
For Each OneCell In Target
If InStr(1, OneCell.Text, strSearchFor, vbTextCompare) > 0 Then
TextSearch = True
Exit For
End if
Next OneCell
ElseIf TypeName(Target) = "String" Then
If InStr(1, Target, strSearchFor, vbTextCompare) > 0 Then TextSearch = True
End If

End Function


------------------------------------------------------------------------------

Reference:

1. http://www.eng-tips.com/viewthread.cfm?qid=127459

http://www.ozgrid.com/forum/showthread.php?t=115687


Option Explicit

Sub Bold1stWord()
Dim rCell As Range

With Selection
.Cells.Copy
.Cells.PasteSpecial xlValues
Application.CutCopyMode = False
For Each rCell In .Cells
rCell.Characters(1, InStr(1, rCell, ":") - 1).Font.Bold = True
Next rCell
End With
End Sub

extract 1 word in cell for macro vba

http://www.teachexcel.com/free-excel-macros/m-138,udf-get-first-word-cell-excel-free-macro.html
Function GETFIRSTWORD(Text As String, Optional Separator As Variant)

Dim firstword As String

If IsMissing(Separator) Then
Separator = " "
End If
firstword = Left(Text, InStr(1, Text, Separator, vbTextCompare))
GETFIRSTWORD = Replace(firstword, Separator, "")

End Function

Excel Macro, VB

http://spreadsheetpage.com/index.php/file/C36/P20/
http://spreadsheetpage.com/index.php/files
- spreadsheet page with different macro and VB program, userform

http://spreadsheetpage.com/index.php/tip/C29

http://spreadsheetpage.com/index.php/tip/displaying_a_menu_of_worksheets_to_print/

tips
http://spreadsheetpage.com/index.php/tips