1. ... 6

. 6

. 6

2. 6

. 6

( ) 7

2. (.. , RTF, XLS ..) 8

_1. 8

_2. 8

_3. 8

_1. 9

_2. 9

_3. 9

_4. 10

. 10

. 10

. 10

. 10

. 10

_2. 11

( ) 11

. 11

. 11

. 11

. 11

. 12

. 13

. 13

_1. 13

_2. 13

HL. 15

. 19

. 19

. 19

RTF . 20

. 21

. 21

. 21

. 22

( ) 22

Word Excel 23

. 24

. 24

_1. 24

_2. 25

_3. 26

3. MICROSOFT EXCEL. 28

. 28

. 28

. 29

( ) 29

1 . 29

. 29

. 29

. 29

, . 29

. 30

.. 30

. 30

. 30

. 31

. 32

. 32

. 33

_1. 34

. 34

() 35

. 35

. 35

. 35

, . 35

. 36

_2. 36

. 36

. 36

. 37

. 37

.. 37

?. 37

. 37

. 38

, _1. 38

, _2. 38

. 39

. 39

. 39

. 39

. 40

. 40

. 41

, . 41

_1. 42

_2. 42

_3. 42

.. 43

. 43

. 43

. 44

_2. 44

. 45

. 45

_2. 46

.. 46

. 47

. 47

. 47

. 47

_1. 48

_2. 48

. 49

. 49

. 50

. 50

. 50

. 50

. 50

_1. 51

_2. 52

. 52

, . 52

. 53

() 53

() 53

() 54

() 54

. 55

. 55

. 55

. 56

. 56

. 56

.. 56

. 56

. 57

. 57

() 59

2. 59

. 60

100. 60

. 60

. 60

. 61

_1. 61

_2. 61

_3. 62

. 62

. 63

. 64

. 64

. 64

. 65

. 65

_2. 66

. 66

. 66

. 67

MsgBox . 68

. 68

. 68

. 68

. 68

. 69

. 69

. 69

. 69

. 69

4. .. 69

. 69

. 70

. 70

_1. 71

_2. 71

_3. 71

_1. 72

_3. 73

. 73

. 73

. 73

. 73

.. 74

. 74

_1. 74

_2. 75

5 . . 75

. 75

. 76

. 76

. 76

. 76

. 77

( 1) 77

( 2) 77

( 3) 78

( 4) 78

( 5) 78

Excel 82

.. 83

. 83

. 85

.. 85

. 86

.. 88

.. 89

. 90

. 90

.. 92

. 93

, , .. 94

. 95

. 95

6. .. 96

INPUTBOX ( ) 96

. 97

( )_1. 97

. 98

. 98

.. 98

7. . . . 98

. 98

. 99

. 99

. 99

. 100

. 101

Excel 101

8 , , .. 104

. 104

. 104

. 104

. 105

9. ... 106

. 106

. 107

. 107

.. 109

.. 109

. 110

.. 112

10. . 112

. 112

. 116

. 118

. 120

11. ... 130

.. 130

. 130

. 131

. 131

. 132

. 132

. 132

. 133

Excel HL-. 133

. 135

. 135

. 136

. 136

. 137

. 137

. 137

.. 138

. 140

. 140

, . 141

12. .. 144

_1. 144

_2. 145

.. 145

. 145

. 146

 


1.

' Sub GotoFixedCell:

' , vVariant

' sSheetName .

'

' Note: ''!

'

Public Sub GotoFixedCell(vValue As Variant, sSheetName As String)

Dim c As Range, cStart As Range, cForFind As Range

Dim i As Integer

 

On Error GoTo errhandle:

 

Set cForFind = Worksheets(sSheetName).Cells '

With cForFind

Set c = .Find(What:=vValue, After:=ActiveCell, LookIn:=xlValues, _

LookAt:= xlart, SearchOrder:=xlByRows,_

SearchDirection:=xlNext, MatchCase:=False)

Set cStart = c

While Not c Is Nothing

Set c = .FindNext(c)

If c.Address = cStart.Address Then

c.Select

Exit Sub

End If

Wend

End With

Exit Sub

errandle:

MsgBox Err.Descrition, vbExclamation, "Error #" & Err.Number

End Sub

Sub Auto_Oen()

2

Private Sub Worksheet_Change(ByVal Target As Range)

Dim w As Object

'On Error Resume Next

If Range("A1").Value = 2 Then

MsgBox "! 2-!"

MsgBox " , !"

Application.VBE.MainWindow.SetFocus

Application.VBE.Windows(1).SetFocus

SendKeys "{F7}", True

End If

End Sub

Private Sub Worksheet_Selectinchange(ByVal Target As Range)

Application.OnKey "{~}", "StartEnter"

End Sub

 

Sub StartEnter()

MsgBox ("sadfsdfsf")

End Sub

( )

Sub Worksheet_Change(ByVal Target As Excel.Range)

Call updtToolbar

End Sub

 

Sub Worksheet_Selectinchange(ByVal Target As Excel.Range)

Call updtToolbar

End Sub

2.43.

Sub FastChangeNumberFormat()

Dim bar As CommandBar

Dim button As CommandBarButton

 

' ( )

On Error Resume Next

CommandBars(" ").Delete

On Error GoTo 0

 

'

Set bar = CommandBars.Add

With bar

.Name = " "

.Visible = True

End With

'

Set button = CommandBars(" ").Controls.Add _

(Type:=msoControlButton)

With button

.Caption = ""

.OnAction = "ChangeNumFormat"

.TooltipText = " "

.Style = msoButtonCaption

End With

'

Call updtToolbar

End Sub

 

Sub updtToolbar()

' ( )

On Error Resume Next

' ( )

CommandBars(" ").Controls(1).Caption = _

ActiveCell.NumberFormat

End Sub

 

Sub ChangeNumFormat()

'

Application.Dialogs(xlDialogFormatNumber).Show

Call updtToolbar

End Sub

 

2. (.. , RTF, XLS ..)

_1

Sub VerifyFileLocation()

Dim strFileName As String

Dim strFileTitle As String

'

strFileTitle = "primer.xls"

strFileName = "C:\\primer.xls"

' ( Dir _

, )

If Dir(strFileName) <> "" Then

MsgBox " " & strFileTitle & " "

Else

MsgBox " " & strFileTitle & " "

End If

End Sub

_2

Sub VerifyFileLocation1()

Dim strFileName As String

'

strFileName = "C:\\primer.xls"

' ( Dir _

, )

If Dir(strFileName) <> "" Then

MsgBox " " & strFileName & " "

Else

MsgBox " " & strFileName & " "

End If

End Sub

_3

Sub Check_Disk()

On Error Resume Next

If Dir("\\192.168.1.200\c\", vbSystem) <> "" Then

If Err = 52 Then

Err.Clear

MsgBox " !", 48, ""

Exit Sub

End If

If Err <> 0 Then

MsgBox " !", 48, ""

Exit Sub

Else

On Error GoTo 0

MsgBox " !", 64, ""

End If

End If

End Sub

 

_1

Sub FileSearch()

Dim strFileName As String

Dim strFolder As String

Dim strFullPath As String

 

'

strFolder = InputBox(" :")

If strFolder = "" Then Exit Sub

'

strFileName = Application.InputBox(" :")

If strFileName = "" Then Exit Sub

' "\"

If Right(strFolder, 1) <> "\" Then strFolder = strFolder & "\"

 

'

strFullPath = strFolder & strFileName

 

' VBA

MsgBox " VBA..." & vbCrLf & vbCrLf & _

dhSearchVBA(strFullPath), vbInformation, strFullPath

' FileSearch

MsgBox " FileSearch..." & vbCrLf & _

vbCrLf & dhSearchFileSearch(strFolder, strFileName), vbInformation, _

strFullPath

' _

FileSystemObject

MsgBox " FileSystemObject..." & vbCrLf & _

vbCrLf & dhSearchFileSystemObject(strFullPath), vbInformation, _

strFullPath

End Sub

_2

 

Function dhSearchVBA(varFullPath As Variant) As Boolean

' VBA

dhSearchVBA = Dir(varFullPath) <> ""

End Function

_3

 

Function dhSearchFileSearch(varFolder As Variant, varFileName _

As Variant) As Boolean

' FileSearch

With Application.FileSearch

'

.NewSearch

'

.FileName = varFileName

'

.LookIn = varFolder

'

.Execute

dhSearchFileSearch = .FoundFiles.Count <> 0

End With

End Function

_4

 

Function dhSearchFileSystemObject(varFullPath As Variant) As Boolean

Dim objFSObject As Object

' FileSystemObject

Set objFSObject = CreateObject("sriting.FileSystemObject")

dhSearchFileSystemObject = objFSObject.FileExists(varFullPath)

End Function

3.51.

Sub DeleteFile()

Kill "C:\\primer.xls"

End Sub

3.52.

Sub DeleteFiles()

' XLS

Kill "C:\" & "*.xls"

End Sub

 

Sub ChangeStatusBarText()

Application.StatusBar = " !!!"

End Sub

Sub ReturnStatusBarText()

Application.StatusBar = False

End Sub

Sub MovingTextInStatusBar()

Dim intSpaces As Integer

' ( 20 0) - _

(, )

For intSpaces = 20 To 0 Step -1

'

Application.StatusBar = Space(intSpaces) & " !!!"

'

Application.Wait Now + TimeValue("00:00:01")

' Excel

DoEvents

Next

Application.StatusBar = False

End Sub

Sub NewTitle()

Application.Caption = " "

End Sub

_2

 

Sub NewTitle()

Application.Caption = " "

ActiveWindow.Caption = " "

End Sub

 

( )

Sub NewTitle()

Application.Caption = " "

ActiveWindow.Caption = ""

End Sub

Sub ReturnTitle()

' ( Excel)

Application.Caption = Empty

' ()

ActiveWindow.Caption = ThisWorkbook.Name

End Sub

Sub WorkBooksList()

Dim book As Object

'

For Each book In Workbooks

MsgBox (book.Name)

Next

End Sub

 

 

Open, - Close.

Sub Test()

Open "file.txt" For Input As #1

Close #1

End Sub

Sub Test()

Open "file.txt" For Output As #1

Print #1, " "

Close #1

 

Open "file.txt" For Input As #1

Dim s As String

Input #1, s

MsgBox s

Close #1

End Sub

 

Print, - Input. .

Print #1, "Hello , File"

 

Input #1 Hello . . , Line Input.

 

Sub Test()

Open "file.txt" For Output As #1

Print #1, "Hello , File"

Close #1

 

Open "file.txt" For Input As #1

Dim s As String

Line Input #1, s

MsgBox s

Close #1

End Sub

 

Sub ImportTextFiles()

Dim fsSearch As FileSearch

Dim strFileName As String

Dim strPath As String

Dim i As Integer

 

'

strFileName = ThisWorkbook.path & "\"

strPath = "text??.txt"

 

' FileSearch

Set fsSearch = Application.FileSearch

'

With fsSearch

'

.LookIn = strFileName

'

.FileName = strPath

' ,

.Execute

' ,

If .FoundFiles.Count = 0 Then

MsgBox " "

Exit Sub

End If

End With

'

For i = 1 To fsSearch.FoundFiles.Count

Call ImportTextFile(fsSearch.FoundFiles(i))

Next i

End Sub

 

Sub ImportTextFile(FileName As String)

'

Workbooks.OpenText FileName:=FileName, _

Origin:=xlWindows, _

StartRow:=1, _

DataType:=xlFixedWidth, _

FieldInfo:= _

Array(Array(0, 1), Array(3, 1), Array(12, 1))

'

Range("D1").Value = "A"

Range("D2").Value = "B"

Range("D3").Value = "C"

Range("E1:E3").Formula = "=COUNTIF(B:B,D1)"

Range("F1:F3").Formula = "=SUMIF(B:B,D1,C:C)"

End Sub

 

 

Sub Test()

Open "file.txt" For Output As #1

Print #1, "Hello , File"

Close #1

Open "file.txt" For Input As #1

Dim s As String

While Not EOF(1)

Input #1, s

MsgBox s

Wend

Close #1

End Sub

Dim TextLine

i = 1

Open "C:\MyFile.txt" For Input As #1

Do While Not EOF(1)

Line Input #1, TextLine

ThisWorkbook.Worksheets("1").Cells(i, 1).Value = TextLine

i = i + 1

Loop

Close #1

_1

Sub Range2TXT()

MyFile = "C:\File.txt" '

Open MyFile For Output As #1 '

For Each i In Selection '

Print #1, i ' ( )

Next

Close #1 '

End Sub

_2

Sub SaveAsText()

Dim cell As Range

' ( _

, - TXT)

Open ThisWorkbook.Path & "\" & ThisWorkbook.Name & ".txt" _

For Output As #1

'

For Each cell In ActiveSheet.UsedRange

If Not IsEmpty(cell) Then

Print #1, cell.Address, cell.Formula

End If

Next

'

Close #1

End Sub

txt

Sub ExportAsText()

Dim lngRow As ****

Dim intCol As Integer

 

'

Open "C:\primer.txt" For Output As #1

' ()

For lngRow = 1 To Selection.Rows.Count

' lngRow

For intCol = 1 To Selection.Columns.Count

Write #1, Selection.Cells(lngRow, intCol).Value;

Next intCol

'

Print #1, ""

Next lngRow

'

Close #1

End Sub

 

Sub ImportText()

Dim strLine As String '

Dim strCurChar As String * 1 '

Dim strValue As String '

Dim lngRow As **** '

Dim intCol As Integer '

Dim i As Integer

 

'

Open "C:\primer.txt" For Input As #1

' , _

, ( )

Do Until EOF(1)

'

Line Input #1, strLine

'

For i = 1 To Len(strLine)

strCurChar = Mid(strLine, i, 1)

If strCurChar = "," Then

' - . _

ActiveCell.Offset(lngRow, intCol) = strValue

intCol = intCol + 1

strValue = ""

ElseIf i = Len(strLine) Then

' - _

( _

, )

If strCurChar <> Chr(34) Then

strValue = strValue & strCurChar

End If

'

ActiveCell.Offset(lngRow, intCol) = strValue

strValue = ""

ElseIf strCurChar <> Chr(34) Then

' _

( )

strValue = strValue & strCurChar

End If

Next i

'

intCol = 0

lngRow = lngRow + 1

Loop

'

Close #1

End Sub

HL

Sub ExportAsHLFile()

Dim strStyle As String '

Dim strAlign As String '

Dim strOut As String ' HL-

Dim cell As Object '

Dim strCellText As String '

Dim lngRow As **** '

Dim lngLastRow As **** '

Dim strTemp As String

Dim strFileName As String ' HL-

Dim i As ****

 

'

strFileName = Application.GetSaveAsFilename( _

InitialFileName:="Primer.htm", _

fileFilter:="HL Files(*.htm), *.htm")

' , ( , _

)

If strFileName = "" Then Exit Sub

 

lngLastRow = Selection.Row

'

For Each cell In Selection

'

lngRow = cell.Row

' , <tr>

If lngRow <> lngLastRow Then

strOut = strOut & vbTab & "</tr>" & vbCrLf & vbTab & _

"<tr>" & vbCrLf

'

lngLastRow = lngRow

End If

 

'

If Not IsNull(cell.Font.Size) Then

strStyle = " style=" & "font-size: " & Int(100 * _

cell.Font.Size / 19) & "%;"

End If

' <b>

If cell.Font.Bold Then

strCellText = "<b>" & strCellText & "</b>"

End If

 

'

If cell.HorizontalAlignment = xlRight Then

'

strAlign = " align=" & "right"

ElseIf cell.HorizontalAlignment = xlCenter Then

'

strAlign = " align=" & "center"

Else

' ( )

strAlign = ""

End If

 

'

strCellText = cell.Text

' , ( strTemp _

strCellText)

If cell.Orientation <> xlHorizontal Then

strTemp = ""

' _

- <br>

For i = 1 To Len(strCellText)

strTemp = strTemp & Mid$(strCellText, i, 1) & "<br>"

Next i

strCellText = strTemp

strStyle = ""

End If

 

strOut = strOut & vbTab & vbTab & "<td" & strStyle & _

strAlign & ">" & strCellText & "</td>" & vbCrLf

Next

' <tr> </tr> -

strOut = vbTab & "<tr>" & vbCrLf & strOut & vbTab & "</tr>" & vbCrLf

' <table>

strOut = "<table border=1 cellpadding=3 cellspacing=1>" _

& vbCrLf & strOut & vbCrLf & "</table>"

 

' HL-

Open strFileName For Output As 1

Print #1, strOut

Close 1

 

'

MsgBox Selection.Count & " " & _

strFileName

End Sub

 

 

 

, 256

Sub ImportWideSheet()

Dim rgRange As Range '

Dim lngRow As **** '

Dim intCol As Integer '

Dim i As Integer

Dim strLine As String ' ( )

Dim strCurChar As String * 1

Dim strCellValue As String ' _

Dim wshtCurrentSheet As Worksheet ' , _

 

'

Application.ScreenUpdating = False

 

'

Workbooks.Add xlWorksheet

Set rgRange = ActiveWorkbook.Sheets(1).Range("A1")

 

' ( _

)

Open ThisWorkbook.Path & "\Primer.txt" For Input As #1

Line Input #1, strLine

' _

For i = 1 To Len(strLine)

strCurChar = Mid(strLine, i, 1)

' -

If intCol <> 0 And intCol Mod 256 = 0 Then

' - _

Set wshtCurrentSheet = ActiveWorkbook.Sheets.Add(, _

ActiveWorkbook.Sheets(ActiveWorkbook.Sheets.Count))

Set rgRange = wshtCurrentSheet.Range("A1")

intCol = 0

End If

 

' -

If strCurChar = "," Then

'

rgRange.Offset(lngRow, intCol) = strCellValue

intCol = intCol + 1

strCellValue = ""

Else

' _

strCellValue = strCellValue & Mid(strLine, i, 1)

 

' -

If i = Len(strLine) Then

' -

rgRange.Offset(lngRow, intCol) = strCellValue

intCol = 0

strCellValue = ""

End If

End If

Next i

 

'

Do Until EOF(1)

Set rgRange = ActiveWorkbook.Sheets(1).Range("A1")

lngRow = lngRow + 1

intCol = 0

Line Input #1, strLine

 

'

For i = 1 To Len(strLine)

strCurChar = Mid(strLine, i, 1)

' -

If intCol <> 0 And intCol Mod 256 = 0 Then

' - _

Set wshtCurrentSheet = ActiveWorkbook.Sheets.Add(, _

ActiveWorkbook.Sheets(ActiveWorkbook.Sheets.Count))

Set rgRange = wshtCurrentSheet.Range("A1")

intCol = 0

End If

 

' -

If strCurChar = "," Then

'

rgRange.Offset(lngRow, intCol) = strCellValue

intCol = intCol + 1

strCellValue = ""

Else

' _

strCellValue = strCellValue & Mid(strLine, i, 1)

 

' -

If i = Len(strLine) Then

' - _

rgRange.Offset(lngRow, intCol) = strCellValue

strCellValue = ""

End If

End If

Next i

Loop

 

'

Close #1

'

Application.ScreenUpdating = True

End Sub

C:\TEMP, .

Sub Backup_Active_Workbook()

Dim x As String

strPath = "c:\TEMP"

On Error Resume Next

x = GetAttr(strPath) And 0

If Err = 0 Then ' -

strDate = Format(Now, "dd/mm/yy hh-mm")

FileNameXls = strPath & "\" & Left(ActiveWorkbook.Name, _

Len(ActiveWorkbook.Name) - 4) & " " & strDate & ".xls"

ActiveWorkbook.SaveCopyAs Filename:=FileNameXls

Else ' -

MsgBox " " & strPath & " !", vbCritical

End If

End Sub

 

:

 

Private Sub Workbook_BeforeClose(Cancel As Boolean)

Module1 , (ThisWorkbook) - .

( 1)

Sub Auto_Open()

Worksheets(1).Cells(1) = Worksheets(1).Cells(1) + 1

End Sub

( 2)

Sub Auto_Open()

Worksheets(1).Cells(1, 1) = Worksheets(1).Cells(1, 1) + 1

End Sub

( 3)

Sub Auto_Open()

Worksheets(1).Range("A1") = Worksheets(1).Range("A1") + 1

End Sub

 

Sub ExcelSearch()

 

Dim fname As String

Dim result As Integer

With Application.FileDialog(1) ' ?????? : With Application.FileDialog(msoFileDialogOpen) '

.Title = "Select Excel file"

 

.InitialFileName = "C:\" 'default path'

.AllowMultiSelect = False

.Filters.Clear

.Filters.Add "Pack files", "*.xls", 1

result = .Show

 

If result = 0 Then Exit Sub

fname = Trim(.SelectedItems.Item(1))

End With

 

'On Error Resume Next

 

ActiveCell = fname

 

 

End Sub

RTF

Sub OpenRtfAndPasteToSheets()

Dim wd As Object

Dim ns As Worksheet

 

On Error Resume Next

'

Set wd = GetObject("", "Word.Application")

If Err.Number <> 0 Then

Err.Clear

Set wd = CreateObject("Word.Application")

If Err.Number <> 0 Then Exit Sub

End If

 

On Error GoTo BAD

 

Do

'

f = Application.GetOpenFilename(" RTF, *.rtf, , *.*")

If TypeName(f) = "Boolean" Then Exit Do ' -

'

Set wdd = wd.Documents.Open(f)

' wd.Visible = True

'

t = wdd.Content.Copy

'

Set ns = ActiveWorkbook.Worksheets.Add

'

ns.Paste Destination:=ns.Cells(1, 1)

'

ns.Cells.WrapText = False

ns.Columns.AutoFit

ns.Rows.AutoFit

wdd.Close

Loop

wd.Quit

Set wd = Nothing

Exit Sub

BAD:

MsgBox Err.Desrition

On Error Resume Next

wd.Quit

Set wd = Nothing

End

End Sub

ActiveCell.FormulaR1C1 = "='D:\contacts\zakaz\[zakaz.xls]1'!R1C1"

Sub GetDataFromFile()

Range("A1").Formula = "='C:\[Example.xls]1'!A1"

End Sub

 

Option Explicit

 

Sub ___()

Dim iShtName$, iPath$, iFileName$, firstAddress$

Dim iSheet As Worksheet, iFoundSht As Worksheet

Dim iTempWB As Workbook, iBazaWB As Workbook

Dim TextToFind As Variant, iFoundRng As Range

Dim FD As FileDialog, iLastRow&

Dim FoundAny As Boolean

 

TextToFind = Application.InputBox(" :", "")

If TextToFind = "" Or TextToFind = False Then Exit Sub

TextToFind = Trim(TextToFind)

Set FD = Application.FileDialog(msoFileDialogFilePicker)

With FD

.AllowMultiSelect = False

.Title = " "

.ButtonName = " "

If .Show = False Then Exit Sub Else iPath = Mid(.SelectedItems(1), 1, InStrRev(.SelectedItems(1), "\"))

End With

Set FD = Nothing

Workbooks.Add

Sheets.Add.Name = ""

Set iFoundSht = ActiveSheet

iFoundSht.Cells(1, 1) = ": " & TextToFind

iFoundSht.Cells(1, 1).Font.Bold = True

With Application

.ScreenUpdating = False

.Calculation = xlManual

.StatusBar = " ..."

.ShowWindowsInTaskbar = False

iFileName = Dir(iPath & "*.xls")

Do While iFileName$ <> ""

Set iTempWB = Workbooks.Open(Filename:=iPath & iFileName, updtLinks:=False, ReadOnly:=True)

For Each iSheet In iTempWB.Sheets

If iSheet.FilterMode = True Then iSheet.ShowAllData

Set iFoundRng = iSheet.Cells.Find(What:=TextToFind, LookIn:=xlFormulas, LookAt:=xlPart)

If Not iFoundRng Is Nothing Then

FoundAny = True

firstAddress = iFoundRng.Address

Do

With iFoundSht

iLastRow = .Cells(.Rows.Count, 1).End(xlUp).Row

If iLastRow = 1 Then iLastRow = 2

If iShtName <> iSheet.Name Then '

With .Cells(iLastRow + 2, 1)

.Value = ": " & iTempWB.Name & ", : " & iSheet.Name

.Font.Bold = True

End With

End If

iFoundRng.EntireRow.Copy Destination:=.Cells(.Cells(.Rows.Count, 1).End(xlUp).Row + 1, 1) '

iShtName = iSheet.Name

End With

Set iFoundRng = iSheet.Cells.FindNext(iFoundRng)

Loop While iFoundRng.Address <> firstAddress

Else

End If

Next

iTempWB.Close SaveChanges:=False

iFileName = Dir

Loop

.StatusBar = False

.ShowWindowsInTaskbar = True

.EnableEvents = True

.Calculation = xlCalculationAutomatic

.ScreenUpdating = True

End With

If FoundAny = False Then

MsgBox " '" & TextToFind & "' :" & Chr(10) & iPath & Chr(10) & " !", 48, ""

iFoundSht.Parent.Close SaveChanges:=False

Exit Sub

End If

MsgBox " " & TextToFind & " !", 64, ""

End Sub

Sub Test()

Open "c:\2.txt" For Output As #1

Print #1, "Hello File"

Close #1

Open "c:\1.txt" For Input As #1

Dim s As String

Input #1, s

MsgBox s

Close #1

End Sub

( )

Sub Test()

Open "c:\1.txt" For Output As #1

Print #1, "Hello , File"

Close #1

Open "c:\1.txt" For Input As #1

Dim s As String

While Not EOF(1)

Input #1, s

MsgBox s

Wend

Close #1

End Sub

Word Excel

Sub ReportToWord()

Dim intReportCount As Integer '

Dim strForWho As String '

Dim strSum As String '

Dim strProduct As String '

Dim strOutFileName As String '

Dim strMessage As String '

Dim rgData As Range '

Dim objWord As Object

Dim i As Integer

 

' Word

Set objWord = CreateObject("Word.Application")

'

Set rgData = Range("A1")

strMessage = Range("E6")

 

' 1

intReportCount = Application.CountA(Range("A:A"))

For i = 1 To intReportCount

'

Application.StatusBar = " " & i

 

'

strForWho = rgData.Cells(i, 1).Value

strProduct = rgData.Cells(i, 2).Value

strSum = Format(rgData.Cells(i, 3).Value, "#,000")

 

'

strOutFileName = ThisWorkbook.path & "\" & strForWho & ".doc"

' Word

With objWord

.Documents.Add

With .Selection

'

.Font.Size = 14

.Font.Bold = True

.ParagraphFormat.Alignment = 1

.TypeText Text:=" "

'

.TypeParagraph

.TypeParagraph

.Font.Size = 12

.ParagraphFormat.Alignment = 0

.Font.Bold = False

.TypeText Text:=":" & vbTab & _

Format(Date, "mmmm d, yyyy")

'

.TypeParagraph

.TypeText Text:=": " & vbTab & strForWho

'

.TypeParagraph

.TypeText Text:=":" & vbTab & Application.UserName

'

.TypeParagraph

.TypeParagraph

.TypeText strMessage

 

.TypeParagraph

.TypeParagraph

'

.TypeText Text:=" :" & vbTab & strProduct

.TypeParagraph

'

.TypeText Text:=" :" & vbTab & _

Format(strSum, "$#,##0")

End With

'

.ActiveDocument.SaveAs FileName:=strOutFileName

End With

Next i

 

' Word

objWord.Quit

Set objWord = Nothing

 

'

Application.StatusBar = False

'

MsgBox intReportCount & " " _

& ThisWorkbook.path

End Sub

 

Sub Test()

MkDir ("c:\test")

End Sub

.

Sub Test()

RmDir ("c:\test")

End Sub

Sub Test()

MsgBox (CurDir)

End Sub

Sub Test()

ChDir ("c:\windows")

MsgBox (CurDir)

End Sub

_1

Sub Test()

Dim s As String

s = Dir("c:\windows\inf\*.*")

Debug.Print s

Do While s <> ""

s = Dir

Debug.Print s

Loop

End Sub

_2

' API- _

Declare Function SHBrowseForFolder Lib "shell32.dll" _

Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As ****

' API- , _

SHBrowseForFolder,

Declare Function SHGetPathFromIDList Lib "shell32.dll" _

Alias "SHGetPathFromIDListA" (ByVal pidl As ****, ByVal _

pszPath As String) As ****

 

' SHBrowseForFolder

Type BROWSEINFO

hwndOwner As **** ' ( )

pidlRoot As **** '

strDisplayName As String

strTitle As String '

ulFlags As **** '

' VBA

lpfn As ****

lParam As ****

iImage As ****

End Type

 

Sub BrowseFolder()

Dim strPath As String ' ,

Dim strFile As String

Dim intRow As **** '

 

'

strPath = dhBrowseForFolder()

If strPath = "" Then Exit Sub

If Right(strPath, 1) <> "\" Then strPath = strPath & "\"

 

'

ActiveSheet.Cells.ClearContents

ActiveSheet.Cells(1, 1) = " "

ActiveSheet.Cells(1, 2) = ""

ActiveSheet.Cells(1, 3) = "/"

ActiveSheet.Range("A1:C1").Font.Bold = True

 

' ...

'

strFile = Dir(strPath, 7)

intRow = 2

Do While strFile <> ""

' "A"

ActiveSheet.Cells(intRow, 1) = strFile

' "B"

ActiveSheet.Cells(intRow, 2) = FileLen(strPath & strFile)

' "C"

ActiveSheet.Cells(intRow, 3) = FileDateTime(strPath & strFile)

'

strFile = Dir

intRow = intRow + 1

Loop

End Sub

 

Function dhBrowseForFolder() As String

Dim biBrowse As BROWSEINFO

Dim strPath As String

Dim lngResult As ****

Dim intLen As Integer

 

' BROWSEINFO

' -

biBrowse.pidlRoot = 0&

'

biBrowse.strTitle = " "

'

biBrowse.ulFlags = &H1

'

lngResult = SHBrowseForFolder(biBrowse)

 

'

If lngResult Then

' ( )

strPath = Space$(512)

If SHGetPathFromIDList(ByVal lngResult, ByVal strPath) Then

' Chr(0)

intLen = InStr(strPath, Chr$(0))

'

dhBrowseForFolder = Left(strPath, intLen - 1)

Else

'

dhBrowseForFolder = ""

End If

Else

' ""

dhBrowseForFolder = ""

End If

End Function

_3

' API- _

Declare Function SHBrowseForFolder Lib "shell32.dll" _

Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As ****

' API- , _

SHBrowseForFolder,

Declare Function SHGetPathFromIDList Lib "shell32.dll" _

Alias "SHGetPathFromIDListA" (ByVal pidl As ****, ByVal _

pszPath As String) As ****

 

' SHBrowseForFolder

Type BROWSEINFO

hwndOwner As **** ' ( )

pidlRoot As **** '

strDisplayName As String

strTitle As String '

ulFlags As **** '

' VBA

lpfn As ****

lParam As ****

iImage As ****

End Type

 

Sub BrowseFolder1()

Dim strPath As String ' ,

Dim strFile As String

Dim intRow As **** '

 

'

strPath = dhBrowseForFolder()

If strPath = "" Then Exit Sub

If Right(strPath, 1) <> "\" Then strPath = strPath & "\"

 

'

ActiveSheet.Cells.ClearContents

ActiveSheet.Cells(1, 1) = " "

ActiveSheet.Cells(1, 2) = ""

ActiveSheet.Cells(1, 3) = "/"

ActiveSheet.Range("A1:C1").Font.Bold = True

 

' ...

'

strFile = Dir(strPath, 7)

intRow = 2

Do While strFile <> ""

' "A"

ActiveSheet.Cells(intRow, 1) = strPath & strFile

' "B"

ActiveSheet.Cells(intRow, 2) = FileLen(strPath & strFile)

' "C"

ActiveSheet.Cells(intRow, 3) = FileDateTime(strPath & strFile)

'

strFile = Dir

intRow = intRow + 1

Loop

End Sub

 

Function dhBrowseForFolder() As String

Dim biBrowse As BROWSEINFO

Dim strPath As String

Dim lngResult As ****

Dim intLen As Integer

 

' BROWSEINFO

' -

biBrowse.pidlRoot = 0&

'

biBrowse.strTitle = " "

'

biBrowse.ulFlags = &H1

'

lngResult = SHBrowseForFolder(biBrowse)

 

'

If lngResult Then

' ( )

strPath = Space$(512)

If SHGetPathFromIDList(ByVal lngResult, ByVal strPath) Then

' Chr(0)

intLen = InStr(strPath, Chr$(0))

'

dhBrowseForFolder = Left(strPath, intLen - 1)

Else

'

dhBrowseForFolder = ""

End If

Else

' ""

dhBrowseForFolder = ""

End If

End Function

3. MICROSOFT EXCEL

Sub CountNames()

Dim intNamesCount As Integer

' _

intNamesCount = Names.Count

If intNamesCount = 0 Then

MsgBox " "

Else

MsgBox ": " & intNamesCount & " ."

End If

End Sub

Sub Worksheet_BeforeRightClick(ByVal Target As Range, _

Cancel As Boolean)

If Target.Address = "$D$2" Then

' ( "123", _

_

)

ThisWorkbook.Protect "123", True, True

' _

Cancel = True

ElseIf Target.Address = "$E$5" Then

' ( _

)

ThisWorkbook.Unprotect "123"

Cancel = True

End If

End Sub

Sub Workbook_BeforePrint(Cancel As Boolean)

' True Exel _

Cancel = True

End Sub

( )

Sub Test()

Application.Workbooks.Open ("c:\file_03.txt")

End Sub

1

Dim Ex As New Excel.Application

Ex.Workbooks.Open " "

Ex.Visible = False

' "A2" "Visual Basic"

Ex.ActiveWorkbook.Sheets.Application.Range("A2") = "Visual Basic"

Ex.ActiveWorkbook.Save

Ex.ActiveWorkbook.Close

Sub Test()

MsgBox (Str(Application.Workbooks.Count))

End Sub

Sub Test()

Application.Workbooks.Item(1).Close (xprssion.Close(SaveChanges, FileName, RouteWorkbook)

End Sub

 

Sub Workbook_BeforeClose(Cancel As Boolean)

If Range("A1").Value <> " " Then

' . Exel _

Cancel = True

End If

End Sub

,

Sub SaveAsDate()

Dim strDate As String

' ""

strDate = Format(Now(), "ddmmyy")

'

ActiveWorkbook.SaveAs ActiveWorkbook.Path & "\" & strDate

End Sub

Function dhBookIsSaved() As Boolean

' , _

(ThisWorkbook.path "")

dhBookIsSaved = ThisWorkbook.path <> ""

End Function

 

Sub NewOneSheetBook()

Workbooks.Add xlWBATWorksheet

End Sub

Sub Test()

Application.Workbooks.Add ("Êíèãà")

End Sub

Sub EraseNames()

Dim nmName As Name

Dim strMessage As String

'

If ThisWorkbook.Names.Count = 0 Then

'

MsgBox " "

Exit Sub

End If

 

' , _

For Each nmName In ThisWorkbook.Names

With nmName

' _

strMessage = " " & .Name & " ? " & vbCr & _

" " & .RefersTo

If MsgBox(strMessage, vbYesNo + vbQuestion) = vbYes Then

'

.Delete

End If

End With

Next

End Sub

Sub DuplicateBook()

Dim avarFileNames As Variant

'

avarFileNames = Array("C:\" & _

ActiveWorkbook.Name, "D:\" & ActiveWorkbook.Name)

'

ActiveWorkbook.SaveAs avarFileNames

End Sub

 

Sub SortSheets()

Dim astrSheetNames() As String '

Dim intSheetCount As Integer

Dim i As Integer

Dim objActiveSheet As Object

 

' -

If ActiveWorkbook Is Nothing Then Exit Sub

 

'

If ActiveWorkbook.ProtectStructure Then

'

MsgBox " " & ActiveWorkbook.Name & _

" . .", _

vbCritical

Exit Sub

End If

 

'

Set objActiveSheet = ActiveSheet

 

' Ctrl+Pause Break

Application.EnableCancelKey = xlDisabled

'

Application.ScreenUpdating = False

 

intSheetCount = ActiveWorkbook.Sheets.Count

' astrSheetNames

ReDim astrSheetNames(1 To intSheetCount)

For i = 1 To intSheetCount

astrSheetNames(i) = ActiveWorkbook.Sheets(i).Name

Next i

 

'

Call Sort(astrSheetNames)

'

For i = 1 To intSheetCount

ActiveWorkbook.Sheets(astrSheetNames(i)).Move _

ActiveWorkbook.Sheets(i)

Next i

 

'

objActiveSheet.Activate

'

Application.ScreenUpdating = True

' Ctrl+Pause Break

Application.EnableCancelKey = xlInterrupt

End Sub

 

Sub Sort(astrNames() As String)

' ( )

Dim i As Integer, j As Integer

Dim strBuffer As String

Dim fBuffer As Boolean

 

For i = LBound(astrNames) To UBound(astrNames) - 1

For j = i + 1 To UBound(astrNames)

If astrNames(i) > astrNames(j) Then

' i- j-

strBuffer = astrNames(i)

astrNames(i) = astrNames(j)

astrNames(j) = strBuffer

End If

Next j

Next i

End Sub

Function dhMaxInBook(cell As Range) As Double

Dim sheet As Worksheet

Dim dblMax As Double

Dim dblResult As Double

Dim fFirst As Boolean

fFirst = True

 

' _

For Each sheet In cell.Parent.Parent.Worksheets

'

dblResult = Application.WorksheetFunction.Max(sheet.UsedRange)

 

If fFirst Then

' -

dblMax = dblResult

fFirst = False

End If

' dblMax dbmResult

If dblResult > dblMax Then

dblMax = dblResult

End If

Next sheet

'

dhMaxInBook = dblMax

End Function

 

 

Sub IsSheetProtected()

' ,

If Worksheets(1).ProtectContents Then

MsgBox " "

Else

MsgBox " "

End If

End Sub

 

Sub SortSheets2()

Dim astrSheetNames() As String '

Dim intSheetCount As Integer

Dim i As Integer

Dim objActiveSheet As Object

' -

If ActiveWorkbook Is Nothing Then Exit Sub

'

If ActiveWorkbook.ProtectStructure Then

'

MsgBox " " & ActiveWorkbook.Name & _

" . .", _

vbCritical

Exit Sub

End If

'

Set objActiveSheet = ActiveSheet

 

' Ctrl+Pause Break

Application.EnableCancelKey = xlDisabled

'

Application.ScreenUpdating = False

 

With ActiveWorkbook

' C "" ( )

On Error Resume Next

If .Sheets("") Is Nothing Then

.Sheets.Add.Name = ""

End If

On Error GoTo 0

 

' "" ( "A")

intSheetCount = .Sheets.Count

For i = 1 To intSheetCount

.Sheets("").Cells(i, 1) = .Sheets(i).Name

Next i

 

' "" _

A

.Sheets("").Range("A1").Sort _

Key1:=.Sheets("").Range("A1"), _

Order1:=xlAscending

 

'

ReDim astrSheetNames(1 To intSheetCount)

For i = 1 To intSheetCount

astrSheetNames(i) = .Sheets("").Cells(i, 1)

Next i

 

'

For i = 1 To intSheetCount

.Sheets(astrSheetNames(i)).Move .Sheets(i)

Next i

End With

 

'

objActiveSheet.Activate

'

Application.ScreenUpdating = True

' Ctrl+Pause Break

Application.EnableCancelKey = xlInterrupt

End Sub

 

_1

Sub NewSheet()

Worksheets.Add

End Sub

 

Sub Tes2t()

With Application.Workbooks.Item(ActiveWorkbook.Name)

Sheets.Add

End With

End Sub

Dim ExNew As Worksheet

Set ExNew = ActiveWorkbook.Worksheets.Add

ExNew.Name = " "

_2

Worksheets.Add.Name = "List12345.xls"

' Function DelSheetByDate

' sSheetName ,

' dDelDate

' True, - False

 

Public Function DelSheetByDate(sSheetName As String, _

dDelDate As Date) As Boolean

On Error GoTo errHandle

 

DelSheetByDate = False

'

If dDelDate <= Date Then

'

Application.DisplayAlerts = False

ActiveWorkbook.Worksheets(sSheetName).Delete

DelSheetByDate = True

Application.DisplayAlerts = True

End If

Exit Function

errHandle:

MsgBox Err.Desrition, vbCritical, " " & Err.Number

End Function

 

Sub Test()

With Application.Workbooks.Item("Test.xls")

Sheets("Test").Copy , after:=Sheets("3")

End With

End Sub

()

Sub Test()

With Application.Workbooks.Item("Test.xls")

Sheets("Test").Copy

End With

End Sub

 

Sub Test()

With Application.Workbooks.Item("Test.xls")

Sheets("Test").Move , after:=Sheets("3")

End With

End Sub

Sheets(Array("1", "2", "3")).Select

Sheets("3").Activate

Sheets(Array("1", "2", "3")).Copy

 

Sub copy_sheet()

ShName = ActiveSheet.Name

Sheets(ShName).Copy

ActiveWorkbook.SaveAs "c:\" & ShName & ".xls"

End Sub

Application.DisplayAlerts = False '

ActiveWorkbook.SaveAs "c:\" & ShName & ".xls"

Application.DisplayAlerts = True ' .

Sub SheetsOfBook()

Dim sheet As Object

'

For Each sheet In ActiveWorkbook.Sheets

MsgBox (sheet.Name)

Next

End Sub

,

Sub AddPageHeader()

Dim i As Integer

With ThisWorkbook

'

For i = 1 To .Worksheets.Count - 1

.Worksheets(i).PageSetup.LeftHeader = .FullName

.Worksheets(i).PageSetup.CenterHeader = Worksheets(i).Name

.Worksheets(i).PageSetup.RightHeader = Now()

Next

End With

End Sub

Function dhSheetExist(strSheetName As String) As Boolean

Dim objSheet As Object

 

On Error GoTo HandleError ' HandleError

'

objSheet = ActiveWorkbook.Sheets(strSheetName)

' -

dhSheetExist = True

Exit Function

 

HandleError:

' _

, ,

dhSheetExist = False

End Function

_2

L = 0

For Each Sheet In Worksheets

If Sheet.Name = "List12" Then

L = 1

MsgBox "List12 . List12 !"

End If

Next

 

If L = 0 Then

Worksheets.Add.Name = "List12"

Worksheets(1).Visible = True

Worksheets("List12").Visible = True

Worksheets("List12").Activate

End If

Sub Test()

MsgBox (Str(Application.Workbooks.Item(ActiveWorkbook.Name).Sheets.Count))

End Sub

Sub SheetNamesAsHyperLinks()

Dim sheet As Worksheet

Dim cell As Range

 

With ActiveWorkbook

' _

For Each sheet In ActiveWorkbook.Worksheets

Set cell = Worksheets(1).Cells(sheet.Index, 1)

.Worksheets(1).Hyperlinks.Add Anchor:=cell, Address:="", _

SubAddress:="'" & sheet.Name & "'" & "!A1"

cell.Formula = sheet.Name

Next

End With

End Sub

 

Sub Test()

With Application.Workbooks.Item(ActiveWorkbook.Name)

For x = 1 To .Sheets.Count

MsgBox (Sheets.Item(x).Name)

Next x

End With

End Sub

Sub ShowInfo()

Dim i As Integer

 

'

Range("A1") = ActiveWorkbook.Name

'

Range("B1") = ActiveSheet.Name

 

'

For i = 1 To ActiveWorkbook.Sheets.Count

ActiveSheet.Cells(i, 3) = i

Next i

End Sub

 

Sub Test()

With Application.Workbooks.Item("Test.xls")

.Sheets.Item("5").Visible = False

End With

End Sub

?

Sub GetPrintPagesCount()

Dim wshtSheet As Worksheet

Dim intPagesCount As Integer

' , _

For Each wshtSheet In Worksheets

intPagesCount = intPagesCount + (wshtSheet.HPageBreaks.Count + 1) * _

(wshtSheet.VPageBreaks.Count + 1)

Next

MsgBox " : " & intPagesCount

End Sub

( )

Sub CopyRows2()

Dim iCells As Range

 

For Each iCells In Range("A2:A5")

Range(iCells, iCells.Offset(, 7)).Copy

Workbooks.Add

ActiveSheet.Paste

ActiveWorkbook.SaveAs Filename:="C:\Temp\" & iCells & ".xls"

Next iCells

End Sub

On Error Resume Next

s = Names("sourcefilename").Value

On Error GoTo 0

If s = "" Then

sfile = "progcall234_56g"

Call get_file

s = sfile

Else

s = Mid(s, 3, Len(s) - 3)

End If

If s = "" Then Exit Sub

 

Workbooks.Open (s)

Dim snm As String

snm = ActiveWorkbook.Name

ncol = WorksheetFunction.CountA(Range("1:1")) ' Range("a1").SpecialCells(xlLastCell).Column

nrow = WorksheetFunction.CountA(Range("a:a")) 'Range("a1").SpecialCells(xlLastCell).Row

Range(Cells(1, 1), Cells(nrow, ncol)).Copy

Workbooks(s1).Activate

Range("a1").Activate

ActiveSheet.Paste

Application.DisplayAlerts = False

Workbooks(snm).Close

, _1

Function dhCount(rgn As Range, LowBound As Double, _

UpperBound As Double) As ****

Dim cell As Range

Dim lngCount As ****

' rgn , _

LowBound UpperBound

For Each cell In rgn

If cell.Value >= LowBound And cell.Value <= UpperBound Then

'

lngCount = lngCount + 1

End If

Next

dhCount = lngCount

End Function

, _2

Function dhCountSomeCells(rgRange As Range, dblMin As Double, _

dblMax As Double) As ****

' dblMin dblMax _

CountIf

With Application.WorksheetFunction

dhCountSomeCells = .CountIf(rgRange, ">=" & dblMin) - _

.CountIf(rgRange, ">" & dblMax)

End With

End Function

 

Function dhCountVisibleCells(rgRange As Range)

Dim lngCount As ****

Dim cell As Range

 

' _

For Each cell In rgRange

' ,

If Not IsEmpty(cell) Then

' ,

If Not cell.EntireRow.Hidden And Not _

cell.EntireColumn.Hidden Then

'

lngCount = lngCount + 1

End If

End If

Next cell

dhCountVisibleCells = lngCount

End Function

Sub CalculateSum()

Dim i As Integer

Dim intSum As Integer

' "A" ( )

For i = 1 To 5

intSum = intSum + Cells(i, 1)

Next

MsgBox " : " & intSum

End Sub

Sub CountOfCells()

MsgBox (Range("A1:A20, D1:D20").Count)

End Sub

Sub Worksheet_Change(ByVal Target As Range)

Dim rgData As Range

Dim cell As Range

Dim dblMax As Double, dblMin As Double, dblAverage As Double

 

'

Set rgData = Range("B2:B11")

' , _

If Not (Application.Intersect(Target, rgData) Is Nothing) Then

If Application.WorksheetFunction.CountA(rgData) > 0 Then

'

' , _

dblMin = Application.WorksheetFunction.Min(rgData)

dblMax = Application.WorksheetFunction.Max(rgData)

dblAverage = Application.WorksheetFunction.Average(rgData)

 

' _

_

, _

For Each cell In rgData

If cell.Value = dblMax Then

'

cell.Font.Bold = True

cell.Font.Color = RGB(255, 0, 0)

ElseIf cell.Value = dblMin Then

'

cell.Font.Bold = False

cell.Font.Color = RGB(0, 0, 255)

Else

cell.Font.Bold = False

cell.Font.Color = RGB(0, 0, 0)

End If

 

If cell.Value > dblAverage Then

' - _

cell.Interior.Color = RGB(255, 255, 0)

Else

cell.Interior.ColorIndex = xlNone

End If

Next

Else

rgData.Interior.ColorIndex = xlNone

End If

End If

End Sub

Sub SetCellData()

' 3 4

Range("A3") = " A3"

Range("B4") = " B4"

End Sub

Sub SetCellFormula()

' 6 "=A5+B5"

Range("A6") = "=A5+B5"

End Sub

Sub StreamInput()

Dim strDate As String

Dim strSum As String

Dim lngRow As ****

' ( , _

"" )

Do

lngRow = Range("A65536").End(xlUp).Row + 1

'

strDate = InputBox(" ")

If strDate = "" Then Exit Sub

'

strSum = InputBox(" ")

If strSum = "" Then Exit Sub

'

Cells(lngRow, 1) = strDate

Cells(lngRow, 2) = strSum

Loop

End Sub

Sub insrtCustomText()

'

ActiveCell = " "

Selection.Font.Bold = True

'

Cells(ActiveCell.Row, ActiveCell.Column + 3).Select

ActiveCell.FormulaR1C1 = ". . "

Selection.Font.Bold = True

 

' " " _

Cells(ActiveCell.Row + 3, ActiveCell.Column - 3).Select

ActiveCell = " "

Selection.Font.Bold = True

'

Cells(ActiveCell.Row, ActiveCell.Column + 3).Select

ActiveCell = ". . "

Selection.Font.Bold = True

End Sub

 

,

Sub Test()

Dim book As String

Dim sheet As String

Dim addr As String

addr = "C"

book = Application.ActiveWorkbook.Name

sheet = Application.ActiveSheet.Name

Workbooks(book).Activate

Worksheets(sheet).Activate

Range("A1") = book

Range("B1") = sheet

Dim xList As Integer

xList = Application.Sheets.Count

For x = 1 To xList

Dim s As String

s = addr + LTrim(Str(x))

Range(s) = x

Next x

End Sub

_1

Selection.SpecialCells(xlCellTypeBlanks).Select

Selection.Delete Shift:=xlUp

_2

Sub DeleteEmptyStrings()

Dim intLastRow As Integer '

Dim intRow As Integer '

 

'

intLastRow = Worksheets(ActiveSheet.Index).UsedRange.Row + _

Worksheets(ActiveSheet.Index).UsedRange.Rows.Count - 1

'

intRow = Worksheets(ActiveSheet.Index).UsedRange.Row

'

Do While intRow <= intLastRow

If ActiveSheet.Rows(intRow).Text = "" Then

'

ActiveSheet.Rows(intRow).Delete

' , _

, -

intLastRow = intLastRow - 1

Else

' -

intRow = intRow + 1

End If

Loop

End Sub

_3

Sub DeleteEmptyStrings1()

Dim intRow As Integer

Dim intLastRow As Integer

 

'

intLastRow = ActiveSheet.UsedRange.Row + _

ActiveSheet.UsedRange.Rows.Count - 1

 

'

For intRow = intLastRow To 1 Step -1

If ActiveSheet.Rows(intRow).Text = "" Then

ActiveSheet.Rows(intRow).Delete

End If

Next intRow

End Sub

Sub 1()

Dim iRange As Range

Dim TextToFindArray As Variant

Dim i As ****

 

TextToFindArray = Array("Toyota", "")

With Application

.ScreenUpdating = False

.Calculation = xlCalculationManual

For i = 0 To 1

With ActiveSheet.Cells

Set iRange = .Find(What:=TextToFindArray(i), LookIn:=xlFormulas, LookAt:=xlPart)

If Not iRange Is Nothing Then

Do

iRange.EntireRow.Delete

Set iRange = .Find(What:=TextToFindArray(i), LookIn:=xlFormulas, LookAt:=xlPart)

Loop While Not iRange Is Nothing

End If

End With

Next i

.Calculation = xlCalculationAutomatic

.ScreenUpdating = True

End With

MsgBox " " & TextToFindArray(0) & " " & TextToFindArray(1) & " !", 64, ""

End Sub

Sub KillHiddenRows()

For Each x In ActiveSheet.Rows

If x.Hidden Then x.Delete

Next

End Sub

 

 

Sub KillUsedHiddenThinRows()

Dim x

For Each x In ActiveSheet.UsedRange.Rows

If x.Hidden Or x.Height = 0 Then x.EntireRow.Delete

Next

End Sub

 

 

Function Two2One(Text As String) As String

Dim Polki, i As Byte, tmp As String

Application.Volatile

Polki = Split(Text, "@")

For i = 1 To UBound(Polki)

If InStr(1, Polki(i), ":") > 0 Then

If Polki(i) <> Polki(i - 1) Then tmp = tmp & "@" & Polki(i)

Else: tmp = tmp & "@" & Polki(i)

End If

Next

Two2One = Polki(0) & tmp

End Function

Sub SelectCellRange()

Dim strSelTop As String, strSelBottom As String

'

strSelBottom = ActiveCell.Address

strSelTop = Cells(1, ActiveCell.Column).Address

' ( )

Range(strSelTop & ":" & strSelBottom).Select

End Sub

_2

Sub SelectColumnData()

'

On Error GoTo errors

'

Dim a1 As String

'

Dim a2 As String

'

Dim ran As Range

'

If (ActiveCell.Row <> 1) Then

'

ActiveCell.Offset(-1, 0).Select

'

a1 = ActiveCell.Address

'

For x = 1 To (ActiveCell.Row - 1)

'

ActiveCell.Offset(-1, 0).Select

'

If IsNumeric(ActiveCell.Value) <> True Then

'

ActiveCell.Offset(1, 0).Select

'

GoTo nexts

End If

'

If IsEmpty(ActiveCell.Value) = True Then

'

ActiveCell.Offset(1, 0).Select

'

GoTo nexts

End If

Next x

nexts:

'

a2 = ActiveCell.Address

'

Set ran = Range(a1 + ":" + a2)

'

ran.Select

End If

'

Exit Sub

'

errors:

MsgBox " "

End Sub

Sub Test()

With Application.Workbooks.Item("Test.xls")

Worksheets("2").Activate

Range("A2") = 2

Range("A3") = 3

End With

End Sub

Sub NegSelect()

Dim cell As Range

' , _

For Each cell In Selection

If cell.Value < 0 Then

cell.Interior.Color = RGB(255, 0, 0)

Else

cell.Interior.ColorIndex = xlNone

End If

Next cell

End Sub

 

Sub Test()

With Application.Workbooks.Item("Test.xls")

Worksheets("2").Activate

Dim HelloRange As Range

Set HelloRange = Range("D3:D10")

HelloRange.Range("A1") = 3

End With

End Sub

_1

Sub IntervalCellSelect()

Dim intFirstRow As Integer '

Dim intLastRow As Integer '

Dim rgCells As Range '

Dim intRow As Integer

 

intFirstRow = 3

intLastRow = 300

 

' "B" _

intFirstRow intLastRow 3

For intRow = intFirstRow To intLastRow Step 3

If rgCells Is Nothing Then

'

Set rgCells = Cells(intRow, 1)

Else

'

Set rgCells = Union(rgCells, Cells(intRow, 1))

End If

Next

'

rgCells.Select

End Sub

_2

Sub IntervalCellSelect()

Dim intFirstRow As Integer '

Dim intLastRow As Integer '

Dim rgCells As Range '

Dim cell As Range '

Dim intRow As Integer

 

intFirstRow = 3

intLastRow = 300

' "B" _

intFirstRow intLastRow 3

For intRow = intFirstRow To intLastRow Step 3

Set cell = Cells(intRow, 1)

Set rgCells = Union(cell, _

IIf(intRow = intFirstRow, cell, rgCells))

Next

'

rgCells.Select

End Sub

Sub SelectRange()

Range("D3:D10, A3:A10 , F3").Select

End Sub

 

.Offset(RowOffset, ColumnOffset)

(Range) .

, :

ActiveCell.Offset(1, 0).Select

, :

ActiveCell.Offset(-1, 0).Select

, .

Sub beg()

Dim a As Boolean

Dim d As Double

Dim c As Range

a = True

Set c = Range(ActiveCell.address)

c.Select

d = c.Value

c.Value = d

While (a = True)

ActiveCell.Offset(1, 0).Select

If (IsEmpty(ActiveCell.Value) = False) Then

Set c = Range(ActiveCell.address)

c.Select

d = c.Value

c.Value = d

Else

a = False

End If

Wend

End Sub

 

Sub FindEmptyCell()

'

Do While Not IsEmpty(ActiveCell.Value)

ActiveCell.Offset(1, 0).Select

Loop

End Sub

Sub FindMaxValue()

On Error Goto NoCell

If Selection.Count > 1 Then

'

Selection.Find(Application.Max(Selection)).Select

Else

'

ActiveSheet.Cells.Find(Application.Max(ActiveSheet.Cells)).Select

End If

Exit Sub

NoCell:

MsgBox " "

End Sub

Sub ReplaceCellsData()

Dim cell As Range

' G1:K20

For Each cell In [G1:K20]

If cell.Value Like "**" Then

cell.Value = ""

cell.Interior.Color = RGB(255, 255, 0)

Else

cell.Interior.Color = RGB(255, 255, 255)

End If

Next

End Sub

Sub Search()

Dim rgResult As Range

' B1:B20

Set rgResult = Range("B1:B20").Find(9999, , xlValues)

If rgResult Is Nothing Then

MsgBox " "

Else

MsgBox rgResult.Address

End If

End Sub

_1

Sub FindAndSelect()

Dim strStartAddr As String ' _

Dim rgResult As Range

 

'

Set rgResult = Range("B1:B10").Find("", , xlValues)

If Not rgResult Is Nothing Then

' ( _

)

strStartAddr = rgResult.Address

End If

Do While Not rgResult Is Nothing

'

rgResult.Interior.Color = RGB(255, 255, 0)

 

'

Set rgResult = Range("B1:B10").FindNext(rgResult)

If rgResult.Address = strStartAddr Then

'

Exit Do

End If

Loop

End Sub

_2

Sub CustomSearch()

Dim strFindData As String

Dim rgFound As Range

Dim i As Integer

 

'

strFindData = InputBox(" ")

'

For i = 1 To Worksheets.Count

With Worksheets(i).Cells

' i-

Set rgFound = .Find(strFindData, LookIn:=xlValues)

If Not rgFound Is Nothing Then

' -

Sheets(i).Select

rgFound.Select

Exit Sub

End If

End With

Next

' .

MsgBox (" ")

End Sub

 

Option Explicit

 

Sub ()

Dim iFoundRng As Range

Dim AutoNum As String

Dim firstAddress As String

Dim LastFoundRng As String

 

AutoNum = Range("E5")

If AutoNum = "" Then

MsgBox " 5!", 48, ""

Exit Sub

End If

On Error Resume Next

LastFoundRng = ActiveWorkbook.Names("LastFoundRngName").RefersToRange.Address

If LastFoundRng = "" Then LastFoundRng = "$C$1"

With Columns("C")

Set iFoundRng = .Find(What:=AutoNum, After:=Range(LastFoundRng), LookIn:=xlFormulas, LookAt:=xlWhole)

If iFoundRng Is Nothing Then

MsgBox " " & AutoNum & " !", "48", ""

Exit Sub

End If

ActiveWorkbook.Names.Add Name:="LastFoundRngName", RefersTo:="=" & ActiveSheet.Name & "!" & iFoundRng.Address, Visible:=False

End With

[E7] = iFoundRng.Offset(0, 1)

[F7] = iFoundRng.Offset(0, 2)

End Sub

Function dhLastUsedCell(rgRange As Range) As ****

Dim lngCell As ****

 

' ( _

)

For lngCell = rgRange.Count To 1 Step -1

If Not IsEmpty(rgRange(lngCell)) Then

'

dhLastUsedCell = lngCell

Exit Function

End If

Next lngCell

'

dhLastUsedCell = 0

End Function

Function dhLastColUsedCell(rgColumn As Range) As Variant

'

dhLastColUsedCell = rgColumn.Parent.Cells(Rows.Count, _

rgColumn.Column).End(xlUp).Value

End Function

Function dhLastRowUsedCell(rgRow As Range) As Variant

'

dhLastRowUsedCell = rgRow.Parent.Cells(rgRow.Row, 256). _

End(xlToLeft).Address

End Function

 

Sub 1()

Dim myRange As Range '

Dim FoundRng As Range '

Dim iRow As ****

Dim iColumn As ****

 

Set myRange = Range("B1:B100")

Application.FindFormat.Interior.ColorIndex = 5 '

Set FoundRng = myRange.Find(What:="", SearchFormat:=True)

If Not FoundRng Is Nothing Then

iRow = FoundRng.Row

iColumn = FoundRng.Column

MsgBox " : " & Chr(13) & ": " & iRow & Chr(13) & ": " & iColumn, vbInformation, ""

Else

MsgBox " !", vbExclamation, ""

End If

End Sub

 

Sub 1()

Dim iCell As Range

Set iCell = Columns(1).Find(What:="*", LookIn:=xlFormulas, SearchDirection:=xlPrevious)

If Not iCell Is Nothing Then

MsgBox " A: " & iCell.Row, , ""

Else

MsgBox " ""A"" ", vbExclamation, ""

End If

End Sub

Option Explicit

 

Sub compare_areas()

Dim r As Range, ar As Range, nm As String, col As Range

Set r = Selection

If r.Count < 2 Then Exit Sub

'Dim r_prog As Integer

'r_prog = prog

'prog = 1

Application.ScreenUpdating = False

nm = ActiveSheet.Name

Sheets.Add

For Each ar In r.Areas

For Each col In ar.Columns

col.Copy

ActiveSheet.Paste

ActiveCell.SpecialCells(xlLastCell).Offset(1, 0).Select

Next

Next

Range(Cells(1, 1), Cells(r.Cells.Count, 2)).Select

Selection.Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlGuess, _

OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _

DataOption1:=xlSortTextAsNumbers

Rows("1:1").Select

Selection.insrt Shift:=xlDown

Cells(2, 2).FormulaR1C1 = "=IF((RC[-1]=R[-1]C[-1])+(RC[-1]=R[1]C[-1]),1,0)"

Range("b2").Select

Selection.AutoFill Destination:=Range(Cells(2, 2), Cells(r.Cells.Count + 1, 2)), Type:=xlFillDefault

Range(Cells(2, 2), Cells(r.Cells.Count + 1, 2)).Copy

Cells(2, 2).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _

:=False, Transpose:=False

Application.CutCopyMode = False

For Each ar In r.Cells

If ar.Value <> Empty Then

If WorksheetFunction.VLookup(ar.Value, Range(Cells(2, 1), Cells(r.Count + 1, 2)), 2, 0) Then

ar.Interior.ColorIndex = 3

End If

End If

Next

Application.DisplayAlerts = False

ActiveSheet.Delete

Sheets(nm).Select

ActiveCell.Select

Application.DisplayAlerts = True

Application.ScreenUpdating = True

'prog = r_prog

End Sub

Sub uncolor()

Selection.Interior.ColorIndex = xlNone

End Sub

_1

Dim r As Range

Dim foundCell As Range

Set r = ActiveSheet.Range("A1:A6")

Set foundCell = r.Find("Ichiro", LookIn:=xlValues)

If Not foundCell Is Nothing Then

foundCell.Select

Else

MsgBox "String not found."

End If

_2

Sub findtekst()

Dim c As Range

Set c = Range("c3:c98").Find("**", , , xlWhole)

If Not c Is Nothing Then c.Select

MsgBox (c)

End Sub

xlWhole :

"*a" - a

"?a*" - 2- a

"??a*" - 3-

"a?" - a 1

"a?*" - 2+ a ( a1, a10, a12, a55, a55dd56 )

"**" - "" ( )

"*" - "" ""

 

Sub wwe()

 

Dim foundCell As Range

 

ActiveWorkbook.Names.Add Name:="ev", RefersToR1C1:= _

"=INDEX(1!R11C2:R34C2,MATCH(MIN(ABS(1!R36C2:R234C2-1!R28C1)),ABS(1!R36C2:R234C2-1!R28C1),0))"

 

Set foundCell = [ev]

Names("ev").Delete

If Not foundCell Is Nothing Then

foundCell.Select

Else

MsgBox "String not found."

End If

 

End Sub

 

,

Sub FindSheetData()

'

MsgBox ActiveSheet.UsedRange.Address

End Sub

Sub FindStartOfData()

With ActiveSheet

' , _

.Cells(.UsedRange.Row, .UsedRange.Column).Value = _

" "

End With

End Sub

 

 

Sub ReplaceValues()

Dim cell As Range

' _

( -1, _

- 1)

For Each cell In Range("C1:C3").Cells

If cell.Value < 0 Then

cell.Value = -1

ElseIf cell.Value > 0 Then

cell.Value = 1

End If

Next

End Sub

()

Sub FillCells()

Dim intStartVal As Integer '

Dim intStep As Integer '

Dim intEndVal As Integer '

Dim intVal As Integer '

Dim intCellOffset As Integer '

 

'

intStartVal = 1

intStep = 1

intEndVal = 100

 

' 1 100

For intVal = intStartVal To intEndVal Step intStep

ActiveCell.Offset(intCellOffset, 0).Value = intVal

intCellOffset = intCellOffset + 1

Next intVal

End Sub

()

Sub FillCells()

Dim intStartVal As Integer '

Dim intStep As Integer '

Dim intEndVal As Integer '

Dim intVal As Integer '

Dim intCellOffset As Integer '

Dim intCellStep As Integer ' _

 

'

intStartVal = 3

intStep = 3

intEndVal = 30

intCellStep = 3

 

' 3 30

For intVal = intStartVal To intEndVal Step intStep

ActiveCell.Offset(intCellOffset, 0).Value = intVal

intCellOffset = intCellOffset + intCellStep

Next intVal

End Sub

()

Sub FillCellRect()

Dim lngRows As ****, intCols As Integer ' _

Dim lngRow As ****, intCol As Integer '

Dim lngStep As ****, lngVal As ****

 

'

lngVal = 1

lngStep = 1

 

' , _

lngRows = Val(InputBox(" "))

intCols = Val(InputBox(" "))

 

'

Application.ScreenUpdating = False

 

'

For lngRow = 1 To lngRows

For intCol = 1 To intCols

ActiveCell.Offset(lngRow, intCol).Value = lngVal

lngVal = lngVal + lngStep

Next intCol

Next lngRow

 

'

Application.ScreenUpdating = True

End Sub

()

Sub FillCellRect1()

Dim lngRows As ****, intCols As Integer

Dim lngRow As ****, intCol As Integer

Dim lngStep As ****, lngVal As ****

Dim alngValues() As ****

Dim rgRange As Range

 

'

lngVal = 1

lngStep = 1

 

' , _

lngRows = Val(InputBox(" "))

intCols = Val(InputBox(" "))

 

ReDim alngValues(1 To lngRows, 1 To intCols)

Set rgRange = ActiveCell.Range(Cells(1, 1), _

Cells(lngRows, intCols))

 

' alngValues

For lngRow = 1 To lngRows

For intCol = 1 To intCols

alngValues(lngRow, intCol) = lngVal

lngVal = lngVal + lngStep

Next intCol

Next lngRow

'

rgRange.Value = alngValues

End Sub

2.65. dhNSum

Function dhNSum(ByVal intCount As Integer, _

rgValues As Range) As Double

Dim i As Integer

Dim dblSum As Double

 

If intCount > rgValues.Count Then

' , _

intCount = rgValues.Count

End If

' intCount

For i = 1 To intCount

dblSum = dblSum + rgValues(i)

Next i

'

dhNSum = dblSum

End Function

 

Sub updtTime()

Dim varNextCall As Variant

'

Cells(1, 1).Value = Now

' varNextCall , _

( 1 )

varNextCall = TimeSerial(Hour(Now), Minute(Now), Second(Now) + 1)

' Excel

Application.OnTime varNextCall, "updtTime"

End Sub

Sub Clock()

' Excel, Alarm 20:55

Application.OnTime TimeValue("20:55:00"), "Alarm"

End Sub

Sub Alarm()

MsgBox " !!!"

End Sub

Sub RangeBorder()

Dim rgRange As Range

Set rgRange = Range("B2:D5")

 

'

With rgRange.Borders(xlEdgeTop)

.Weight = xlThick

.LineStyle = xlContinuous

.Color = RGB(0, 0, 255)

End With

'

With rgRange.Borders(xlEdgeBottom)

.Weight = xlMedium

.LineStyle = xlDash

.Color = RGB(255, 0, 255)

End With

End Sub

Sub Worksheet_Selectinchange(ByVal Target As Range)

'

MsgBox Target.Address() & vbCr & _

Target.Address(RowAbsolute:=False) & vbCr & _

Target.Address(ReferenceStyle:=xlR1C1) & vbCr & _

Target.Address(ReferenceStyle:=xlR1C1, _

RowAbsolute:=False, ColumnAbsolute:=False, _

RelativeTo:=Worksheets(1).Cells(2, 2))

End Sub

ActiveCell.Row ActiveCell.Column - .

s = Range("A3").Formula

Sub Test()

With Application.Workbooks.Item("Test.xls")

Worksheets("2").Activate

Range("A2") = 2

Range("A3") = "=A2+2"

MsgBox Range("A3").Formula + " - " + Str(Range("A3").Value)

End With

End Sub

Function dhCellType(rgRange As Range) As String

' , rgRange - , _

Set rgRange = rgRange.Range("A1")

'

Select Case True

Case IsEmpty(rgRange)

'

dhCellType = ""

Case Application.IsText(rgRange)

'

dhCellType = ""

Case Application.IsLogical(rgRange)

' (True False)

dhCellType = " "

Case Application.IsErr(rgRange)

'

dhCellType = ""

Case IsDate(rgRange)

'

dhCellType = ""

Case InStr(1, rgRange.Text, ":") <> 0

'

dhCellType = ""

Case IsNumeric(rgRange)

'

dhCellType = ""

End Select

End Function

 

Sub TestRange()

Dim r As Range

Set r = Range("rrrrr")

MsgBox (r.Columns.End(xlUp).Address)

MsgBox (r.Columns.End(xlDown).Address)

End Sub

Sub TypeOfSelection()

Dim rgSelUnion As Range '

Dim strTitle As String '

Dim strMessage As String '

Dim strSelType As String ' ( _

)

Dim intBlockCount As Integer '

Dim intCellCount As **** '

Dim intColCount As Integer '

Dim intRowCount As **** '

Dim intAreasCount As Integer '

Dim strCurSelType As String

Dim rgArea As Range

 

' : _

( ) ( )

intAreasCount = Selection.Areas.Count

If intAreasCount = 1 Then

strTitle = " "

Else

strTitle = " "

End If

 

'

strSelType = dhGetAreaType(Selection.Areas(1))

 

' _

Set rgSelUnion = Selection.Areas(1)

For Each rgArea In Selection.Areas

strCurSelType = dhGetAreaType(rgArea)

' , _

If strCurSelType <> strSelType Then

strSelType = ""

End If

 

'

If strCurSelType = "Block" Then

intBlockCount = intBlockCount + 1

End If

'

Set rgSelUnion = Union(rgSelUnion, rgArea)

Next rgArea

 

'

For Each rgArea In rgSelUnion.Areas

Select Case dhGetAreaType(rgArea)

Case ""

intRowCount = intRowCount + rgArea.Rows.Count

Case ""

intColCount = intColCount + rgArea.Columns.Count

Case ""

intColCount = intColCount + rgArea.Columns.Count

intRowCount = intRowCount + rgArea.Rows.Count

End Select

Next rgArea

'

intCellCount = rgSelUnion.Count

 

'

strMessage = " :" & vbTab & strSelType & vbCrLf & _

" : " & vbTab & intAreasCount & vbCrLf & _

" : " & vbTab & intColCount & vbCrLf & _

" : " & vbTab & intRowCount & vbCrLf & _

" : " & vbTab & intBlockCount & vbCrLf & _

" : " & vbTab & Format(intCellCount, "#,###")

MsgBox strMessage, vbInformation, strTitle

End Sub

 

Function dhGetAreaType(rgRangeArea As Range) As String

'

If rgRangeArea.Count = Cells.Count Then

'

dhGetAreaType = ""

ElseIf rgRangeArea.Cells.Count = 1 Then

'

dhGetAreaType = ""

ElseIf rgRangeArea.Rows.Count = Cells.Rows.Count Then

'

dhGetAreaType = ""

ElseIf rgRangeArea.Columns.Count = Cells.Columns.Count Then

'

dhGetAreaType = ""

Else

'

dhGetAreaType = ""

End If

End Function

13

' 4

iMonth = " 2 008 2 008 "

' 13-

iMonth = Evaluate("MID(TRIM(" & """" & iMonth & """" & "),13,(SEARCH("" "",TRIM(" & """" & iMonth & """" & "),13)-13))")

 

'

AddressSht.Range("A1") = iMonth

()

Sub 2()

With ActiveSheet

.ListObjects.Add(xlSrcRange, .Range("$A$8:$AR$" & .Cells(Rows.Count, 1).End(xlUp).Row), , xlYes).Name = _

"1"

End With

End Sub

IsNull() -

Sub Test()

With ActiveWorkbook

Worksheets("1").Activate

Dim Range1 As Range

Set Range1 = Range("A1:A8 A8:D8")

Range1.Value = "test"

End With

End Sub

 

2

 

Sub Test()

Dim cur_range As Range

With ActiveSheet

Set cur_range = Selection

cur_range.Activate

 

For x = 1 To cur_range.Rows.Count

For y = 1 To cur_range.Columns.Count

' 2

cur_range(x, y) = cur_range(x, y).Value * 2

Next y

Next x

 

End With

End Sub

Sub MultAllCells()

Dim dblMult As Double

Dim cell As Range

'

dblMult = InputBox(" , ")

'

For Each cell In Selection

If IsNumeric(cell.Value) And cell.Value <> "" Then

' ,

cell.Value = cell.Value * dblMult

Else

MsgBox " " & cell.Address & " "

End If

Next

End Sub

 

100

Sub Test23()

Dim iRange As Range

Dim kRange As Range

i = 1

j = 1

m = 5

n = 2

Set iRange = Range(Cells(i, j), Cells(m, n))

For Each kRange In iRange

kRange.Value = kRange.Value / 100

Next

End Sub

Function () As Double

'

For Each In

'

If Not .EntireRow.Hidden And Not _

.EntireColumn.Hidden Then

' _

If IsNumeric() = True Then

= +

End If

End If

Next

End Function

Sub CalculateSum()

Dim i As Integer

Dim intSum As Integer

' "A" ( )

For i = 1 To 5

If IsNumeric(Cells(i, 1)) Then

intSum = intSum + Cells(i, 1)

End If

Next

MsgBox " : " & intSum

End Sub

 

Function (, ) As Double

'

For Each In

' , _

If .Address <> .Address Then

' _

If IsNumeric() = True Then

= +

End If

End If

Next

End Function

_1

Function dhCalculatePercent(lngSum As ****) As Double

' ( )

Const dblRate1 As Double = 0.09

Const dblRate2 As Double = 0.11

Const dblRate3 As Double = 0.15

' ( )

Const intSum1 As **** = 5000

Const intSum2 As **** = 10000

 

' ,

If lngSum < intSum1 Then

dhCalculatePercent = lngSum * dblRate1

ElseIf lngSum < intSum2 Then

dhCalculatePercent = lngSum * dblRate2

Else

dhCalculatePercent = lngSum * dblRate3

End If

End Function

_2

Function dhCalculatePercent(lngSum As ****) As Double

' ( )

Const dblRate1 As Double = 0.09

Const dblRate2 As Double = 0.11

Const dblRate3 As Double = 0.15

' ( )

Const intSum1 As **** = 5000

Const intSum2 As **** = 10000

 

' ,

Select Case lngSum

Case Is < intSum1

dhCalculatePercent = lngSum * dblRate1

Case Is < intSum2

dhCalculatePercent = lngSum * dblRate2

Case Else

dhCalculatePercent = lngSum * dblRate3

End Select

End Function

_3

Function dhCalculatePercent(Sales As ****, IsTemporal As Boolean) As Double

' ( )

Const dblRate1 As Double = 0.09

Const dblRate2 As Double = 0.11

Const dblRate3 As Double = 0.15

Const dblAdd As Double = 1.1

'

Const lngSum1 As **** = 5000

Const lngSum2 As **** = 10000

 

' ( )

If Sales < lngSum1 Then

dhCalculatePercent = Sales * dblRate1

ElseIf Sales < lngSum2 Then

dhCalculatePercent = Sales * dblRate2

Else

dhCalculatePercent = Sales * dblRate3

End If

 

If IsTemporal Then

' -

dhCalculatePercent = dblAdd * dhCalculatePercent

End If

End Function

Function dhCalculateCom(dblSales As Double) As Double

Const dblRate1 = 0.09

Const dblRate2 = 0.11

Const dblRate3 = 0.15

' ( ) _

Select Case dblSales

Case 0 To 4999.99: dhCalculateCom = dblSales * dblRate1

Case 5000 To 9999.99: dhCalculateCom = dblSales * dblRate2

Case Is >= 10000: dhCalculateCom = dblSales * dblRate3

End Select

End Function

 

Function dhCalculateCom2(dblSales As Double, intYears As Double) _

As Double

Const dblRate1 = 0.09

Const dblRate2 = 0.11

Const dblRate3 = 0.15

' ( ) _

Select Case dblSales

Case 0 To 4999.99: dhCalculateCom2 = dblSales * dblRate1

Case 5000 To 9999.99: dhCalculateCom2 = dblSales * dblRate2

Case Is >= 10000: dhCalculateCom2 = dblSales * dblRate3

End Select

'

dhCalculateCom2 = dhCalculateCom2 + _

(dhCalculateCom2 * intYears / 100)

End Function

 

Sub ComCalculator()

Dim strMessage As String

Dim dblSales As Double

Dim As Integer

 

Calc:

'

dblSales = Val(InputBox(" :", _

" "))

 

' ( _

)

strMessage = " :" & vbTab & Format(dblSales, "$#,##0") & _

vbCrLf & " :" & vbTab & _

Format(dhCalculateCom(dblSales), "$#,##0") & _

vbCrLf & vbCrLf & " ?"

 

' ( _

)

If MsgBox(strMessage, vbYesNo, _

" ") = vbYes Then

'

GoTo Calc

End If

End Sub

 

Sub FullShach()

For Each c In Range(addressdiap)

If c.Value > yr1 Then

c.Select

With Selection.Interior

.ColorIndex = 6

.Pattern = xlSolid

End With

Selection.Font.ColorIndex = yrcolor1

If c.Value > yr2 Then

c.Select

Selection.Font.ColorIndex = yrcolor2

If c.Value > yr3 Then

c.Select

Selection.Font.ColorIndex = yrcolor3

End If

End If

End If

Next c

 

End Sub

Sub Test()

Dim cur_range As Range

Set cur_range = Range("A1")

Set cur_range = cur_range.Offset(1, 0)

Debug.Print cur_range.Address

End Sub

Sub beg()

Dim a As Boolean

Dim d As Double

Dim c As Range

a = False

Set c = Range(ActiveCell.Address)

c.Select

d = c.Value

c.Value = d

While (a = False)

ActiveCell.Offset(1, 0).Select

If (IsEmpty(ActiveCell.Value) = False) Then

Set c = Range(ActiveCell.Address)

c.Select

d = c.Value

c.Value = d

Else

a = False

End If

Wend

End Sub

Sub FillRange()

'

With Range("B1:E10")

' -

.Interior.Pattern = xlPatternChecker

' -

.Interior.PatternColor = RGB(0, 0, 255)

' -

.Interior.Color = RGB(255, 0, 0)

End With

End Sub

Sub 1()

' : Ctrl+

Range("G5").GoalSeek Goal:=4, ChangingCell:=Range("G4")

End Sub

Function ExtractElement(Txt, n, Separator) As String

' n- Txt,

' Separator

Dim Txt1 As String, TempElement As String

Dim ElementCount As Integer, i As Integer

Txt1 = Txt

' ,

'

If Separator = Chr(32) Then Txt1 = Application.Trim(Txt1)

' ( )

If Right(Txt1, 1) <> Separator Then Txt1 = Txt1 & Separator

'

ElementCount = 0

TempElement = ""

'

For i = 1 To Len(Txt1)

If Mid(Txt1, i, 1) = Separator Then

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)

End If

Next i

ExtractElement = ""

End Function

Excel File - Close and return to Microsoft Excel.

- - , :

Txt - , ,

n - ,

Separator - -.

Function Couple(Diapazon)

' , _

Diapazon ( - )

' iCell -

For Each iCell In Diapazon

'

If IsEmpty(iCell) <> True Then

'

If Couple = "" Then

Couple = iCell

Else

Couple = Couple & " " & iCell

End If

End If

Next

End Function

_2

Function CoupleFormat(Diapazon)

' , _

Diapazon ( - )

' iCell -

For Each iCell In Diapazon

'

If IsEmpty(iCell) <> True Then

'

If CoupleFormat = "" Then

CoupleFormat = iCell.Text

Else

CoupleFormat = CoupleFormat & " " & iCell.Text

End If

End If

Next

End Function

 

.

Sub Test()

With ActiveSheet

Dim cur_range As Range

Set cur_range = .UsedRange

Debug.Print cur_range.Address

End With

End Sub

Sub Worksheet_Change(ByVal Target As Excel.Range)

Dim rgInputRange As Range

Dim cell As Range

Dim strMessage As String

Dim varResult As Variant

 

' ,

Set rgInputRange = Range("A1:E10")

' , _

For Each cell In Target

'

If Union(cell, rgInputRange).Address = rgInputRange.Address Then

'

varResult = IsCellDataValid(cell)

If varResult = True Then

'

Exit Sub

Else

'

strMessage = " " & cell.Address(False, False) & ":" _

& vbCrLf & vbCrLf & varResult

MsgBox strMessage, vbCritical, " "

'

Application.EnableEvents = False

cell.ClearContents

cell.Activate

Application.EnableEvents = True

End If

End If

Next cell

End Sub

 

Function IsCellDataValid(cell As Range) As Variant

' True, _

1 12. _

 

' ,

If Not WorksheetFunction.IsNumber(cell.Value) Then

IsCellDataValid = " "

Exit Function

End If

' ,

If Int(cell.Value) <> cell.Value Then

IsCellDataValid = " "

Exit Function

End If

'

If cell.Value < 1 Or cell.Value > 12 Then

IsCellDataValid = " 1 12"

Exit Function

End If

 

'

IsCellDataValid = True

End Function

Sub TableSpeedTest()

Dim alngData() As **** '

Dim lngCount As **** '

Dim dtStart As Date ' ( ) _

Dim strArrayToTable As String '

Dim strTableToArray As String '

Dim strMessage As String

Dim i As ****

 

'

Range("A:A").ClearContents

 

' ,

lngCount = InputBox(" ")

ReDim alngData(1 To lngCount)

'

For i = 1 To lngCount

alngData(i) = i

Next i

 

'

Application.ScreenUpdating = False

dtStart = Timer

For i = 1 To lngCount

Cells(i, 1) = i

Next i

strArrayToTable = Format(Timer - dtStart, "00:00")

 

'

dtStart = Timer

For i = 1 To lngCount

alngData(i) = Cells(i, 1)

Next i

strTableToArray = Format(Timer - dtStart, "00:00")

Application.ScreenUpdating = True

 

'

strMessage = ": " & strArrayToTable & vbCrLf & _

": " & strTableToArray

MsgBox strMessage, , lngCount & " "

End Sub

 

MsgBox

Private Sub Worksheet_Selectinchange(ByVal Target As Range)

If Target.Address = "$A$1" Then MsgBox "Hello world"

End Sub

Sub HideString()

Rows(2).Hidden = True

End Sub

Sub HideStrings()

Rows("3:5").Hidden = True

End Sub

Sub HideCollumn()

Columns(2).Hidden = True

End Sub

Sub HideCollumns()

Columns("E:F").Hidden = True

End Sub

Sub HideCell()

Range("").EntireRow.Hidden = True

End Sub

Sub HideCell()

Range("B3:D4").EntireRow.Hidden = True

End Sub

Sub HideCell()

Range("").EntireColumn.Hidden = True

End Sub

Sub HideCell()

Range("C2:D5").EntireColumn.Hidden = True

End Sub

Sub BlinkingCell()

Static intCalls As Integer '

 

' 10 , _

If intCalls < 10 Then

intCalls = intCalls + 1

' ,

If Range("A1").Interior.Color <> RGB(255, 0, 0) Then

' , _

Range("A1").Interior.Color = RGB(255, 0, 0)

Else

'

Range("A1").Interior.Color = RGB(0, 255, 0)

End If

 

' 5

Application.OnTime Now + TimeValue("00:00:05"), "BlinkingCell"

Else

'

Range("A1").Interior.ColorIndex = xlNone

intCalls = 0

End If

End Sub

 

4.

Sub ShowComments()

Dim cell As Range

Dim rgCells As Range

 

'

Set rgCells = Selection.SpecialCells(xlComments)

If rgCells Is Nothing Then

'

Exit Sub

End If

'

For Each cell In rgCells

'

cell.Next.Value = cell.Comment.Text

Next

End Sub

Function GetCommentText(rCommentCell As Range)

Dim strGotIt As String

On Error Resume Next

strGotIt = WorksheetFunction.Clean _

(rCommentCell.Comment.Text)

GetCommentText = strGotIt

On Error GoTo 0

End Function

 

Sub ShowComments1()

Dim cell As Range

Dim strFirstAddress As String

Dim strComments As String

 

' ,

Set cell = Selection.Find("*", LookIn:=xlComments)

If Not cell Is Nothing Then

' _

( )

strFirstAddress = cell.Address

Do

'

strComments = strComments & ": " & _

cell.Comment.Text & Chr(13)

'

Set cell = Selection.FindNext(cell)

Loop While Not cell Is Nothing And _

cell.Address <> strFirstAddress

End If

If strComments <> "" Then

'

MsgBox strComments

Else

MsgBox " / "

End If

End Sub

_1

Sub ListOfComments()

Dim cell As Range

Dim rgCells As Range

Dim intRow As Integer

 

'

On Error Resume Next

Set rgCells = Selection.SpecialCells(xlComments)

If rgCells Is Nothing Then

'

Exit Sub

End If

'

For Each cell In rgCells

' "C"

intRow = intRow + 1

Cells(intRow, 3) = cell.Comment.Text

Next

End Sub

_2

Sub ListOfComments1()

Dim cell As Range

Dim strFirstAddress As String

Dim intRow As Integer

 

' ,

Set cell = Cells.Find("*", LookIn:=xlComments)

If Not cell Is Nothing Then

' _

( )

strFirstAddress = cell.Address

Do

' "C"

intRow = intRow + 1

Cells(intRow, 3) = cell.Comment.Text

'

Set cell = Cells.FindNext(cell)

Loop While Not cell Is Nothing And _

cell.Address <> strFirstAddress

End If

End Sub

_3

Sub ListOfCommentsToFile()

Dim rgCells As Range '

Dim intDefListCount As Integer ' _

Dim strSheet As String '

Dim strWorkBook As String '

Dim intRow As Integer

Dim cell As Range

 

'

On Error Resume Next

Set rgCells = ActiveSheet.Cells.SpecialCells(xlComments)

On Error GoTo 0

' ,

If rgCells Is Nothing Then

MsgBox " .", _

vbInformation

Exit Sub

End If

 

'

strSheet = ActiveSheet.Name

strWorkBook = ActiveWorkbook.Name

 

' _

intDefListCount = Application.SheetsInNewWorkbook

Application.SheetsInNewWorkbook = 1

Workbooks.Add

Application.SheetsInNewWorkbook = intDefListCount

ActiveWorkbook.Windows(1).Caption = "Comments for " & strSheet & _

" in " & strWorkBook

 

'

Cells(1, 1) = ""

Cells(1, 2) = ""

Cells(1, 3) = ""

Range(Cells(1, 1), Cells(1, 3)).Font.Bold = True

intRow = 2 '

For Each cell In rgCells

Cells(intRow, 1) = cell.Address(rowabsolute:=False, _

columnabsolute:=False)

Cells(intRow, 2) = " " & cell.Formula

Cells(intRow, 3) = cell.comment.Text

intRow = intRow + 1

Next

End Sub

 

_1

Sub CountOfComments()

Dim intCommentCount As Integer

'

intCommentCount = ActiveSheet.Comments.Count

If intCommentCount = 0 Then

MsgBox " .", _

vbInformation

Else

MsgBox " " & intCommentCount _

& " .", vbInformation

End If

End Sub

_2

' Function IsCommentsPresent

' TRUE,

' , FALSE

'

Public Function IsCommentsPresent() As Boolean

IsCommentsPresent = ( ActiveSheet.Comments.Count <> 0 )

End Function

_3

Sub CountOfComment()

Dim intCommentCount As Integer

' _

intCommentCount = ActiveSheet.Comments.Count

If intCommentCount = 0 Then

MsgBox " "

Else

MsgBox ": " & intCommentCount & " ."

End If

End Sub

 

Sub SelectComments()

'

Cells.SpecialCells(xlCellTypeComments).Select

End Sub

Sub ShowComments()

'

If Application.DisplayCommentIndicator = xlCommentAndIndicator Then

Application.DisplayCommentIndicator = xlCommentIndicatorOnly

Else

Application.DisplayCommentIndicator = xlCommentAndIndicator

End If

End Sub

Sub ChangeCommentColor()

'

Dim comment As comment

For Each comment In ActiveSheet.Comments

'

comment.Shape.Fill.ForeColor.SchemeColor = Int((80) * Rnd + 1)

comment.Shape.TextFrame.Characters.Font.ColorIndex = Int((56 _

) * Rnd + 1)

Next

End Sub

Dim r As Range

Dim rwIndex As Integer

For rwIndex = 1 To 3

Set r = Worksheets("WombatBattingAverages").Cells(rwIndex, 2)

With r

If .Value >= 0.3 Then

.AddComment "All Star!"

End If

End With

Next rwIndex

 

Sub CreateComments()

Dim cell As Range

' _

, ""

For Each cell In Range("B1:B100")

If cell.Value Like "**" Then

cell.ClearComments

cell.AddComment " "

End If

Next

End Sub

 

Sub ____()

'

Dim i As ****

Dim c As Range, cc As Range

Dim iCommment As Comments

Application.DisplayCommentIndicator = xlCommentIndicatorOnly

Application.ScreenUpdating = False

Application.Calculation = xlCalculationManual

Set cc = Selection

' 1 ,

If cc.Rows.Count = 1 And cc.Columns.Count = 1 Then

MsgBox " !", , ""

End

End If

Set cc = Selection.SpecialCells(xlCellTypeVisible)

For Each c In cc

If Not c.Comment Is Nothing Then

c.Value = c.Comment.Text

'c.ClearComments '

i = i + 1

End If

End If

Next

Application.Calculation = xlCalculationAutomatic

Application.ScreenUpdating = True

MsgBox " " & i & " !"

Exit Sub

End Sub

 

_1

 

Sub ___()

'

Dim c As Range, cc As Range

Dim i As ****

On Error GoTo ErrorHandler

Application.DisplayCommentIndicator = xlCommentIndicatorOnly

Set cc = Selection

' 1 ,

If cc.Rows.Count = 1 And cc.Columns.Count = 1 Then

MsgBox " !", , ""

End

End If

Set cc = Selection.SpecialCells(xlCellTypeVisible)

For Each c In cc

If c.Value <> Empty Then

c.AddComment CStr(c.Value)

i = i + 1

End If

Next

MsgBox " " & i & " !"

Exit Sub

End Sub

_2

 

Sub Comment_in_Cell()

Dim c As Range

Dim r As Range

If ActiveSheet.Comments.Count = 0 Then MsgBox " !": Exit Sub

Set sh = ActiveSheet

Set shnew = Sheets.Add

sh.Select

Set r = Range(Cells(1, 1), Cells(Cells.Find("*", [A1], xlComments, , xlByRows, _

xlPrevious).Row, Cells.Find("*", [A1], xlComments, , xlColumns, _

xlPrevious).Column))

For Each c In r

If Not c.Comment Is Nothing Then

shnew.Range(c.Address) = c.Comment.Text

End If

Next

End Sub

 

5 .

 

Sub AddCustomCommandBar()

'

With Application.CommandBars(3).Controls.Add(Type:=msoControlButton)

.FaceId = 42 ' Word

.Caption = ""

.OnAction = ""

End With

End Sub

Sub AddCustomButton()

'

With Application.Toolbars(1).ToolbarButtons.Add(button:=222)

.Name = ""

.OnAction = ""

End With

End Sub

Sub CreateCustomControlBar()

'

With Application.CommandBars.Add(Name:="", Temporary:=True)

'

With .Controls.Add(Type:=msoControlButton)

.Style = msoButtonIconAndCaption

.FaceId = 66

.Caption = " "

End With

'

.Visible = True

End With

End Sub

Sub CreateCustomControlBar()

'

With Application.CommandBars.Add(Name:="", Temporary:=True, _

Position:=msoBarLeft)

'

With .Controls.Add(Type:=msoControlButton)

.Style = msoButtonWrapCaption

.Caption = " "

End With

'

With .Controls.Add(Type:=msoControlButton)

.Style = msoButtonIconAndWrapCaption

.Caption = ""

.FaceId = 225

End With

'

.Visible = True

End With

End Sub

Sub CreateCustomControlBar()

'

With Application.CommandBars.Add(Name:=" ", _

Temporary:=True)

'

With .Controls.Add(Type:=msoControlButton)

.Style = msoButtonWrapCaption

.Caption = ""

End With

 

' -

.Position = msoBarRight

'

.Visible = True

End With

End Sub

Sub Test()

With Application.Workbooks.Item("Test.xls")

Sheets("Test").PrintPreview

End With

End Sub

 

( 1)

Sub AddCustomMenu()

'

With Application.CommandBars(1).Controls.Add(Type:=msoControlPopup, _

Temporary:=True)

.Caption = ""

With .Controls

'

With .Add(Type:=msoControlButton)

.FaceId = 280

.Caption = ""

.OnAction = "1"

End With

'

With .Add(Type:=msoControlPopup)

.Caption = " "

With .Controls

' _

With .Add(Type:=msoControlButton)

.FaceId = 1643

.Caption = ""

.OnAction = "2"

End With

' _

With .Add(Type:=msoControlButton)

.FaceId = 1000

.Caption = ""

.OnAction = "3"

End With

End With

End With

End With

End With

End Sub

( 2)

Sub AddCustomMenu1()

' "" , _

With MenuBars("Worksheet").Menus.Add(Caption:="")

'

.MenuItems.Add Caption:="", OnAction:="1"

'

With .MenuItems.AddMenu(Caption:=" ")

'

.MenuItems.Add Caption:="", OnAction:="2"

.MenuItems.Add Caption:="", OnAction:="3"

End With

End With

End Sub

( 3)

Sub AddCustomMenu2()

' "" , _

With MenuBars("Worksheet").Menus.Add(Caption:="")

'

.MenuItems.Add Caption:="", OnAction:="1"

'

With .MenuItems.AddMenu(Caption:=" ")

'

With .MenuItems.Add(Caption:="")

'

.OnAction = "2"

End With

'

With .MenuItems.Add(Caption:="")

'

.OnAction = "3"

End With

End With

End With

End Sub

( 4)

 

Sub Workbook_Open()

'

strMenuName = "MyCommandBarName"

'

CreateCustomMenu

End Sub

( 5)

 

Sub Workbook_BeforeClose(Cancel As Boolean)

'

DeleteCustomMenu

End Sub

 

Public strMenuName As String '

Private cbrcBar As CommandBarControl

 

Sub CreateCustomMenu()

Dim cbrMenu As CommandBar

Dim cbrcMenu As CommandBarControl ' ""

Dim cbrcSubMenu As CommandBarControl ' ""

 

' ,

DeleteCustomMenu

 

'

Set cbrMenu = Application.CommandBars.Add(strMenuName, msoBarTop, _

True, True)

' ""

Set cbrcMenu = cbrMenu.Controls.Add(msoControlPopup, , , , True)

With cbrcMenu

.Caption = "&"

End With

 

'

With cbrcMenu.Controls.Add(Type:=msoControlButton, _

Temporary:=True)

.Caption = "&1"

.OnAction = "CallMenu1"

End With

'

With cbrcMenu.Controls.Add(Type:=msoControlButton, _

Temporary:=True)

.Caption = "2"

.OnAction = "CallMenu2"

End With

'

Set cbrcSubMenu = cbrcMenu.Controls.Add(Type:=msoControlPopup, _

Temporary:=True)

With cbrcSubMenu

.Caption = "1"

.BeginGroup = True

End With

'

With cbrcMenu.Controls.Add(Type:=msoControlButton, _

Temporary:=True)

.Caption = "/"

.OnAction = "MenuOnOff"

.Style = msoButtonIconAndCaption

.FaceId = 463

End With

'

With cbrcSubMenu.Controls.Add(Type:=msoControlButton, _

Temporary:=True)

.Caption = "1"

.OnAction = "CallSubMenu1"

.Style = msoButtonIconAndCaption

.FaceId = 2950

.State = msoButtonDown

End With

' C ( _

"/"), _

Set cbrcBar = cbrcSubMenu.Controls.Add(Type:=msoControlButton, _

Temporary:=True)

With cbrcBar

.Caption = "2"

.OnAction = "CallSubMenu2"

'

.Enabled = False

End With

'

Set cbrcSubMenu = cbrcSubMenu.Controls.Add(Type:=msoControlPopup, _

Temporary:=True)

With cbrcSubMenu

.Caption = "1"

.BeginGroup = True

End With

' C

With cbrcSubMenu.Controls.Add(Type:=msoControlButton, _

Temporary:=True)

.Caption = "1"

.OnAction = "CallLastMenu1"

.Style = msoButtonIconAndCaption

.FaceId = 71

.State = msoButtonDown

End With

' C

With cbrcSubMenu.Controls.Add(Type:=msoControlButton, _

Temporary:=True)

.Caption = "2"

.OnAction = "CallLastMenu2"

.Style = msoButtonIconAndCaption

.FaceId = 72

.Enabled = True

End With

 

'

cbrMenu.Visible = True

Set cbrcSubMenu = Nothing

Set cbrcMenu = Nothing

Set cbrMenu = Nothing

End Sub

 

Sub DeleteCustomMenu()

'

On Error Resume Next

Application.CommandBars(strMenuName).Delete

On Error GoTo 0

End Sub

 

Sub CallMenu1()

' 1

MsgBox " 1!", vbInformation, ThisWorkbook.Name

End Sub

Sub CallMenu2()

' 2

MsgBox " 2!", vbInformation, ThisWorkbook.Name

End Sub

 

Sub CallSubMenu1()

' 1

MsgBox " 1!", vbInformation, ThisWorkbook.Name

End Sub

Sub CallSubMenu2()

' 2

MsgBox " 2!", vbInformation, ThisWorkbook.Name

End Sub

 

Sub CallLastMenu1()

' 1

MsgBox " 1!", vbInformation, ThisWorkbook.Name

End Sub

 

Sub CallLastMenu2()

' 2

MsgBox " 2!", vbInformation, ThisWorkbook.Name

End Sub

 

Sub MenuOnOff()

' "-1-2"

cbrcBar.Enabled = Not cbrcBar.Enabled

End Sub

( 6)

Sub CreateMenu()

Dim cbrMenu As CommandBar

Dim cbrcNewMenu As CommandBarControl

 

' ,

Call DeleteMenu

'

Set cbrMenu = CommandBars.Add(MenuBar:=True)

With cbrMenu

.Name = " "

.Visible = True

End With

 

' ""

CommandBars("Worksheet Menu Bar").FindControl(ID:=30002).Copy _

CommandBars(" ")

 

' - ""

Set cbrcNewMenu = cbrMenu.Controls.Add(msoControlPopup)

cbrcNewMenu.Caption = "&"

 

'

With cbrcNewMenu.Controls.Add(msoControlButton)

.Caption = "& "

.OnAction = "DeleteMenu"

End With

'

With cbrcNewMenu.Controls.Add(Type:=msoControlButton)

.Caption = "&"

End With

End Sub

 

Sub DeleteMenu()

' (, )

On Error Resume Next

CommandBars(" ").Delete

On Error GoTo 0

End Sub

Sub ListOfMenues()

Dim intRow As Integer '

Dim cbrBar As CommandBar

'

Cells.Clear

intRow = 1 '

' _

For Each cbrBar In CommandBars

'

Cells(intRow, 1) = cbrBar.Index

'

Cells(intRow, 2) = cbrBar.Name

'

Select Case cbrBar.Type

Case msoBarTypeNormal

Cells(intRow, 3) = " "

Case msoBarTypeMenuBar

Cells(intRow, 3) = " "

Case msoBarTypePopup

Cells(intRow, 3) = " "

End Select

'

Cells(intRow, 4) = cbrBar.BuiltIn

 

'

intRow = intRow + 1

Next

End Sub

Excel

3.90.

Sub ListOfMenues()

Dim intRow As Integer ' ,

Dim cbrcMenu As CommandBarControl '

Dim cbrcSubMenu As CommandBarControl '

Dim cbrcSubSubMenu As CommandBarControl '

 

'

Cells.Clear

'

intRow = 1

 

'

On Error Resume Next '

For Each cbrcMenu In CommandBars(1).Controls

' cbrcMenu

For Each cbrcSubMenu In cbrcMenu.Controls

' cbrcSubMenu

For Each cbrcSubSubMenu In cbrcSubMenu.Controls

'

Cells(intRow, 1) = cbrcMenu.Caption

'

Cells(intRow, 2) = cbrcSubMenu.Caption

'

Cells(intRow, 3) = cbrcSubSubMenu.Caption

 

'

intRow = intRow + 1

Next cbrcSubSubMenu

Next cbrcSubMenu

Next cbrcMenu

End Sub

3.91.

Sub ListOfContextMenues()

Dim intRow As ****

Dim intControl As Integer

Dim cbrBar As CommandBar

 

'

Cells.Clear

'

intRow = 1

 

'

For Each cbrBar In CommandBars

If cbrBar.Type = msoBarTypePopup Then

'

Cells(intRow, 1) = cbrBar.Index

'

Cells(intRow, 2) = cbrBar.Name

' _

For intControl = 1 To cbrBar.Controls.Count

Cells(intRow, intControl + 2) = _

cbrBar.Controls(intControl).Caption

Next intControl

'

intRow = intRow + 1

End If

Next cbrBar

 

'

Cells.EntireColumn.AutoFit

End Sub

3.92.

Sub Worksheet_Selectinchange(ByVal Target As Excel.Range)

'

If Union(Target, Range("A1:D5")).Address = _

Range("A1:D5").Address Then

' -

CommandBars("AutoSense").Visible = True

Else

' -

CommandBars("AutoSense").Visible = False

End If

End Sub

3.93.

Sub CreatePanel()

Dim cbrBar As CommandBar

Dim button As CommandBarButton

Dim i As Integer

 

' ( )

On Error Resume Next

CommandBars("AutoSense").Delete

On Error GoTo 0

 

'

Set cbrBar = CommandBars.Add

'

For i = 1 To 4

Set button = cbrBar.Controls.Add(msoControlButton)

With button

.OnAction = "Buttnclick" & i

.FaceId = i + 37

End With

Next i

cbrBar.Name = "AutoSense"

End Sub

 

Sub Buttnclick3()

'

On Error Resume Next

ActiveCell.Offset(1, 0).Activate

End Sub

 

Sub Buttnclick1()

'

On Error Resume Next

ActiveCell.Offset(-1, 0).Activate

End Sub

 

Sub Buttnclick2()

'

On Error Resume Next

ActiveCell.Offset(0, 1).Activate

End Sub

 

Sub Buttnclick4()

'

On Error Resume Next

ActiveCell.Offset(0, -1).Activate

End Sub

3.94.

Sub HidePanels()

Dim cbrBar As CommandBar

Dim intRow As Integer '

 

'

Application.ScreenUpdating = False

'

Cells.Clear

 

'

intRow = 1 '

For Each cbrBar In CommandBars

If cbrBar.Type = msoBarTypeNormal Then

If cbrBar.Visible Then

cbrBar.Visible = False

Cells(intRow, 1) = cbrBar.Name

intRow = intRow + 1

End If

End If

Next

'

Application.ScreenUpdating = True

End Sub

 

Sub ShowPanels()

Dim cell As Range '

 

'

Application.ScreenUpdating = False

'

On Error Resume Next

For Each cell In Range("A:A").SpecialCells( _

xlCellTypeConstants)

CommandBars(cell.Value).Visible = True

Next cell

'

Application.ScreenUpdating = True

End Sub

' C

ublic Sub InitToolBar()

Dim cmdbarSM As CommandBar

Dim ctlNewBtn As CommandBarButton

 

Set cmdbarSM = CommandBars.Add(Name:="MyToolBar",

Position:=msoBarFloating, _

temporary:=True)

With cmdbarSM

' 1)

Set ctlNewBtn = .Controls.Add(Type:=msoControlButton)

With ctlNewBtn

. FaceId = 26

.OnAction = "OnButton1_Click"

.TooltipText = "My tooltip message!"

End With

' 2)

Set ctlNewBtn = .Controls.Add(Type:=msoControlButton)

With ctlNewBtn

.FaceId = 44

.OnAction = "OnButton2_Click"

.TooltipText = "Another tooltip message!"

End With

.Visible = True

End With

End Sub

 

 

3.95.

Sub Workbook_Open()

'

Call CreateCustomMenu

End Sub

Sub Workbook_BeforeClose(Cancel As Boolean)

'

Call DeleteCustomMenu

End Sub

3.96.

Sub CreateMenu()

Dim sheet As Worksheet '

Dim intRow As Integer '

Dim cbrpBar As CommandBarPopup '

Dim objNewItem As Object ' cbrpBar

Dim objNewSubItem As Object ' objNewItem

Dim intMenuLevel As Integer '

Dim strCaption As String '

Dim strAction As String '

Dim fIsDevider As Boolean '

Dim intNextLevel As Integer ' _

Dim strFaceID As String '

 

'

Set sheet = ThisWorkbook.Sheets("")

 

' ( )

Call DeleteMenu

 

'

intRow = 2

'

Do Until IsEmpty(sheet.Cells(intRow, 1))

'

With sheet

'

intMenuLevel = .Cells(intRow, 1)

'

strCaption = .Cells(intRow, 2)

'

strAction = .Cells(intRow, 3)

' ?

fIsDevider = .Cells(intRow, 4)

' ( )

strFaceID = .Cells(intRow, 5)

'

intNextLevel = .Cells(intRow + 1, 1)

End With

'

Select Case intMenuLevel

Case 1

'

Set cbrpBar = Application.CommandBars(1). _

Controls.Add(Type:=msoControlPopup, _

Before:=strAction, _

Temporary:=True)

cbrpBar.Caption = strCaption

Case 2

'

If intNextLevel = 3 Then

' , _

Set objNewItem = _

cbrpBar.Controls.Add(Type:=msoControlPopup)

Else

'

Set objNewItem = _

cbrpBar.Controls.Add(Type:=msoControlButton)

objNewItem.OnAction = strAction

End If

'

objNewItem.Caption = strCaption

' ( )

If strFaceID <> "" Then

objNewItem.FaceId = strFaceID

End If

' ,

If fIsDevider Then

objNewItem.BeginGroup = True

End If

Case 3

'

Set objNewSubItem = _

objNewItem.Controls.Add(Type:=msoControlButton)

'

objNewSubItem.Caption = strCaption

' ( )

objNewSubItem.OnAction = strAction

' ( )

If strFaceID <> "" Then

objNewSubItem.FaceId = strFaceID

End If

' ,

If fIsDevider Then

objNewSubItem.BeginGroup = True

End If

End Select

'

intRow = intRow + 1

Loop

End Sub

 

Sub DeleteMenu()

Dim sheet As Worksheet '

Dim intRow As Integer '

Dim strCaption As String '

 

Set sheet = ThisWorkbook.Sheets("")

'

intRow = 2

' , "A", _

( 1)

On Error Resume Next

Do Until IsEmpty(sheet.Cells(intRow, 1))

If sheet.Cells(intRow, 1) = 1 Then

strCaption = sheet.Cells(intRow, 2)

Application.CommandBars(1).Controls(strCaption).Delete

End If

intRow = intRow + 1

Loop

On Error GoTo 0

End Sub

3.97.

Sub Worksheet_BeforeRightClick(ByVal Target As Excel.Range, _

Cancel As Boolean)

' ,

If Union(Target.Range("A1"), Range("A2:D5")).Address = _

Range("A2:D5").Address Then

'

CommandBars("MyContextMenu").ShowPopup

Cancel = True

End If

End Sub

3.98.

Sub Workbook_Open()

'

Call CreateCustomContextMenu

End Sub

 

Sub Workbook_BeforeClose(Cancel As Boolean)

'

Call DeleteCustomContextMenu

End Sub

 

Sub CreateCustomContextMenu()

'

Call DeleteCustomContextMenu

 

'

With CommandBars.Add("MyContextMenu", msoBarPopup, , True).Controls

'

' " "

With .Add(msoControlButton)

.Caption = "& ..."

.OnAction = "ShowFormatNumber"

.FaceId = 1554

End With

' ""

With .Add(msoControlButton)

.Caption = "&..."

.OnAction = "ShowFormatAlignment"

.FaceId = 217

End With

' ""

With .Add(msoControlButton)

.Caption = "&..."

.OnAction = "ShowFormatFont"

.FaceId = 291

End With

' "