Vba macros for excel access - Word и Excel - помощь в работе с программами

When you create a new database, you typically begin by creating several database objects such as tables, forms, and reports. Eventually, you reach a point where you have to add some programming to automate certain processes and tie your database objects together. This article helps orient you to the programming tools in Access.

What is programming?

In Access, programming is the process of adding functionality to your database by using Access macros or Visual Basic for Applications (VBA) code. For example, suppose that you have created a form and a report, and you want to add a command button to the form that, when clicked, opens the report. Programming, in this case, is the process of creating a macro or VBA procedure and then setting the command button’s OnClick event property so that clicking the command button runs the macro or procedure. For a simple operation, such as opening a report, you can use the Command Button Wizard to do all the work, or you can turn off the wizard and do the programming yourself.

Note: Many Microsoft Office programs use the term «macro» to refer to VBA code. This can be confusing to Access users because, in Access, the term «macro» refers to a named collection of macro actions that you can assemble by using the Macro Builder. Access macro actions represent only a subset of the commands available in VBA. The Macro Builder gives you a more structured interface than the Visual Basic Editor, enabling you to add programming to controls and objects without having to learn VBA code. You should remember that in Access Help articles, Access macros are referred to as macros. Conversely, VBA code is referred to as VBA, code, a function, or a procedure. VBA code is contained in class modules (which are part of individual forms or reports and typically contain code just for those objects) and in modules (which are not tied to specific objects and typically contain «global» code that can be used throughout the database).

Objects (such as forms and reports) and controls (such as command buttons and text boxes) have various event properties to which you can attach macros or procedures. Each event property is associated with a specific event, such as clicking the mouse, opening a form, or modifying data in a text box. Events can also be triggered by factors outside of Access, such as system events, or by macros or procedures that are attached to other events. Your database can get complex if you add many macros or procedures to several event properties of many objects, but in most cases, you can achieve the results that you want by using very little programming.

Top of Page

Should I use macros or should I use VBA code?

The decision to use macros, VBA, or both depends primarily on how you plan to deploy or distribute the database. For example, if the database is stored on your computer and you are the sole user, and if you are comfortable using VBA code, you might decide to use VBA to perform most of your programming tasks. However, if you intend to share your database with other people by locating it on a file server, you might want to avoid using VBA for security considerations.

You should base your decision to use either macros or VBA code on two concerns: security and the functionality that you want. Security is an issue because VBA can be used to create code that either compromises the security of your data or can harm files on your computer. When you use a database that was created by someone other than yourself, you should enable VBA code only if you know the database comes from a trustworthy source. When you create a database that will be used by other people, you should try to avoid including programming tools that require the user to specifically grant trusted status to the database. General techniques for avoiding the need for users to trust your database come later in this section.

To help ensure the security of your database, you should try to use macros when you can and use VBA programming only for operations that cannot be performed by using macro actions. Furthermore, you should try to use only macro actions that don’t require granting trusted status to the database in order to run. Limiting the use of macro actions in this manner lets users to be confident that the database has no programming that could harm the data or other files on their computers.

Macro considerations

Beginning in the Access 2010 release, Access contains many new macro actions that enable you to build more powerful macros than you can build by using earlier versions of Access. For example, you can now create and use global temporary variables by using macro actions, and you can handle errors more gracefully by using new error-handling macro actions. In earlier versions of Access, these kinds of features are available only by using VBA. In addition, you can embed a macro directly into the event property of an object or control. An embedded macro becomes a part of the object or control and stays with the object or control if it is moved or copied.

Macros provide an easy way to handle many programming tasks, such as opening and closing forms and running reports. You can quickly and easily tie together the database objects (forms, reports, and so on) that you have created because there is little syntax that you must remember. The arguments for each action are displayed in the Macro Builder.

In addition to the increased security and ease of use that macros provide, you must use macros to perform the following tasks:

Assign an action or set of actions to a key. This requires creating a macro group named AutoKeys.
Carry out an action or a series of actions when a database first opens. This requires creating a macro named AutoExec.

Note: The AutoExec macro runs before any other macros or VBA code, even if you have designated a startup form in the Access Options dialog box and attached a macro or VBA code to that form’s OnOpen or OnLoad event.

For more information about how to build macros, see the section Understand macros.

VBA considerations

You should use VBA programming instead of macros if you want to do any of the following:

Use built-in functions, or create your own functions Access includes many built-in functions, such as the IPmt function, which calculates an interest payment. You can use these built-in functions to perform calculations without having to create complicated expressions. By using VBA code, you can also create your own functions either to perform calculations that exceed the capability of an expression or to replace complex expressions. In addition, you can use the functions that you create in expressions to apply a common operation to more than one object.
Create or manipulate objects In most cases, you will find that it is easiest to create and modify an object in that object’s Design view. In some situations, however, you might want to manipulate the definition of an object in code. By using VBA, you can manipulate all the objects in a database, in addition to the database itself.
Perform system-level actions You can carry out the RunApp action in a macro to run another program (such as Microsoft Excel) from within Access, but you can’t use a macro to do much else outside of Access. By using VBA, you can check to see whether a file exists on the computer, use Automation or Dynamic Data Exchange (DDE) to communicate with other Microsoft Windows-based programs, such as Excel, and call functions in Windows dynamic-link libraries (DLLs).
Manipulate records one at a time You can use VBA to step through a set of records, one record at a time, and perform an operation on each record. In contrast, macros work with entire sets of records at one time.

Top of Page

Use the Command Button Wizard to perform common programming tasks

If you are adding a command button to a form, the Command Button Wizard can help you get started with programming. The wizard helps you create a command button that performs a specific task. In an Access (.accdb) file, the wizard creates a macro that is embedded in the OnClick property of the command button. In an .mdb or .adp file, the wizard creates VBA code, because embedded macros are not available in those file formats. In either case, you can then modify or enhance the macro or VBA code to better suit your needs.

In the Navigation Pane, right-click the form to which you want to add the command button, and then click Design View.
On the Design tab, click the down arrow to display the Controls gallery, and then ensure that Use Control Wizards is selected.
On the Design tab, in the Controls gallery, click Button.
In the form design grid, click where you want the command button to be placed.

The Command Button Wizard starts.
On the first page of the wizard, click each category in the Categories list to see which actions the wizard can program the command button to perform. In the Actions list, select the action that you want, and then click Next.
Click either the Text option or the Picture option, depending on whether you want text or a picture to be displayed on the command button.
- If you want text to be displayed, you can edit the text in the box next to the Text option.
- If you want a picture to be displayed, the wizard suggests a picture in the list. If you want to select a different picture, select the Show All Pictures check box to display a list of all the command button pictures that Access provides, or click Browse to select a picture that is stored elsewhere.
  
  Click Next.
Enter a meaningful name for the command button. This is an optional step, and this name is not displayed on the command button. However, it is a good idea to enter a meaningful name so that when you need to refer to the command button later (for example, if you are setting the tab order for controls on your form), it will be much easier to differentiate between the command buttons. If the command button closes the form, for example, you might name it cmdClose or CommandClose.
Click Finish.

Access places the command button on the form.
If you want to see what the wizard «programmed» for you, follow these optional steps:
1. If the property sheet is not already displayed, press F4 to display it.
2. Click the Event tab in the property sheet.
3. In the On Click property box, click the Build button .
  
  Access starts the Macro Builder and displays the macro that the wizard created. You can edit the macro if you want (for more information about how to edit a macro, see the section Understand macros). When you are finished, on the Design tab, in the Close group, click Close to close the Macro Builder. If Access prompts you to save the changes and update the property, click Yes to save the changes or No to reject the changes.
On the Design tab, in the Views group, click View, and then click Form View. Click the new command button to confirm that it works as you expected.

Top of Page

Understand macros

A macro is a tool that enables you to automate tasks and add functionality to your forms, reports, and controls. For example, if you add a command button to a form, you associate the button’s OnClick event property to a macro that contains the commands that you want the button to perform each time that it is clicked.

It is helpful to think of Access macros as a simplified programming language in which you create code by building a list of actions to perform. When you build a macro, you select each action from a drop-down list and then fill in the required information for each action. Macros enable you to add functionality to forms, reports, and controls without writing code in a VBA module. Macros provide a subset of the commands that are available in VBA, and most people find it easier to build a macro than to write VBA code.

You create a macro by using the Macro Builder, which is shown in the following illustration.

To display the Macro Builder:

On the Create tab, in the Macros & Code group, click Macro.

Top of Page

Understand VBA code

Like macros, VBA lets you add automation and other functionality to your Access application. You can extend VBA by using third-party controls, and you can write your own functions and procedures for your own specific needs.

A quick way to get started with VBA programming is to first build an Access macro and then convert it to VBA code. Instructions for doing this are included in the section Convert macros to VBA code. This feature creates a new VBA module that performs the equivalent operations in the macro. It also opens the Visual Basic Editor so that you can start modifying the procedure. When you are working in the Visual Basic Editor, you can click keywords and press F1 to start Access Developer Help and learn more about each keyword. You can then explore Access Developer Help and discover new commands to help you perform the programming tasks that you want.

Top of Page

Convert macros to VBA code

You can use Access to automatically convert macros to VBA modules or class modules. You can convert macros that are attached to a form or report, whether they exist as separate objects or as embedded macros. You can also convert global macros that are not attached to a specific form or report.

Note: You can add Visual Basic for Applications (VBA) code to a Web database; however, you cannot run that code while the database is running in a Web browser. If your Web database contains VBA code, you must first open the Web database by using Access before you can run the code. To perform programming tasks in a Web database, use Access macros instead.

Convert macros that are attached to a form or report

This process converts to VBA any macros that are referred to by (or embedded in) a form or report (or any of its controls) and adds the VBA code to the form or report’s class module. The class module becomes part of the form or report and moves with the form or report if it is moved or copied.

In the Navigation Pane, right-click the form or report, and then click Design view.
On the Design tab, in the Tools group, click either Convert Form’s Macros To Visual Basic or Convert Report’s Macros To Visual Basic.
In the Convert form macros or Convert report macros dialog box, select whether you want Access to add error handling code to the functions it generates. Also, if you have any comments in your macros, select whether you want to have them included as comments in the functions. Click Convert to continue.

If no class module exists for the form or report, Access creates one and adds a procedure to the module for each macro that was associated with the form or report. Access also changes the event properties of the form or report so that they run the new VBA procedures instead of the macros.
To view and edit the VBA code:
1. While the form or report is still open in Design view, if the property sheet is not already displayed, press F4 to display it.
2. On the Event tab of the property sheet, click in any property box that displays [Event Procedure], and then click the build button . To view the event properties for a specific control, click the control to select it. To view the event properties for the entire form or report, select Form or Report from the drop-down list at the top of the property sheet.
  
  Access opens the Visual Basic Editor and displays the event procedure in its class module. You can scroll up or down to view any other procedures that are in the same class module.

Convert global macros

In the Navigation Pane, right-click the macro that you want to convert, and then click Design View.
On the Design tab, in the Tools group, click Convert Macros To Visual Basic.
In the Convert Macro dialog box, select the options that you want, and then click Convert.

Access converts the macro and opens the Visual Basic Editor.
To view and edit the VBA code:
1. In the Visual Basic Editor, if the Project Explorer pane is not displayed, on the View menu, click Project Explorer.
2. Expand the tree under the name of the database in which you are working.
3. Under Modules, double-click the module Converted Macro- macro name.
  
  The Visual Basic Editor opens the module.

Attach a VBA function to an event property

When you convert a global macro to VBA, the VBA code is placed in a standard module. Unlike a class module, a standard module is not part of a form or report. You will most likely want to associate the function with an event property on a form, report, or control so that the code runs exactly when and where you want. To do this, either you can copy the VBA code into a class module and then associate it with an event property, or you can make a special call from the event property to the standard module by using the following procedure.

In the Visual Basic Editor, make a note of the function name. For example, if you converted a macro named MyMacro, the function name will be MyMacro().
Close the Visual Basic Editor.
In the Navigation Pane, right-click the form or report with which you want to associate the function, and then click Design View.
Click the control or section with which you want to associate the function.
If the property sheet is not already displayed, press F4 to display it.
On the Event tab of the property sheet, click the event property box with which you want to associate the function.
In the property box, type an equal sign (=) followed by the name of the function — for example, =MyMacro(). Be sure to include the parentheses.
Save the form or report by clicking Save on the Quick Access Toolbar.
In the Navigation Pane, double-click the form or report, and test it to see that the code runs as it should.

You now know the basic steps to add VBA code to your database. This article describes only the basics of how to get started; there are many excellent reference books and online resources that can help you build your programming skills.

Top of Page

Источник

VBA Barcode Macro & Functions Tutorial

for Microsoft Office Excel, Access & Word on Windows or
Mac

IDAutomation VBA Barcode Functions and Macros allow easy
generation of barcodes in Microsoft Office Suite applications
such as Excel, Word and Access on both Windows® and Mac
operating systems, compatible with Excel 2003 and greater in Windows and Excel 2011 and greater on Mac. The VBA modules are also compatible with legacy VB6.

These font encoders are used to format
the data-to-encode into a special string that will display an
accurate barcode when the appropriate font is applied to it.
Supported barcode types include Code 128, Code 39, Postnet,
Intelligent Mail IMb, Interleaved 2 of 5, DataBar, UPC/EAN and
many others. IDAutomation font encoder tools may be used with
a demo or purchased version of compatible

IDAutomation Barcode Font package.

Download Now
Excel VBA App

VBA Barcode Macro & Functions Overview

«The IDAutomation Code 128 Barcode Font and
VBA Macros enabled us to integrate barcoding into a
Microsoft Excel spreadsheet that works cross-platform
between Classic Macintosh, OS X and Microsoft Windows
operating systems.»
— Charles Daneri, Objective
Systems, LLC (computer consulting firm), Baltimore,
MD.

These Office Macros consist of pure VBA modules with customizable
code, functions, and other options that allow for dynamic and
variable data barcode generation. Consequently, this also means
that the implementation may be more complicated for the average
user. These font encoder tools format data into a text string
that will display a readable barcode when the appropriate IDAutomation
font is applied to it.

Import & Export VBA
Excel Tutorial
Excel Font Encoder App
Access Tutorial
Mail Merge for Word Tutorial
Barcode Functions

The Macros are free to use with the purchase of any IDAutomation
linear barcode font and are compatible with Microsoft Office
2000 and greater running on Windows® or Office 2004 and 2011
for Mac platforms. This tool is not compatible with Office 2008
for Mac because that version does not have VBA capability. IDAutomation
has a variety of
Mac Barcode
Integration options for those using Microsoft Office 2008
for Mac. Mac users and those located outside of the US Western
character set should use the

IDAutomation Universal Barcode Font Advantage package with
related Universal Font VBA
functions for Code 128 and Interleaved 2 of 5 fonts.

Download Now

Importing and Exporting VBA in
Excel

The barcode Macros and functions reside inside the Excel
file as a custom VBA module. To use these barcode functions
in an Excel spreadsheet, the IDAutomationVBA module
must be imported. If the IDAutomationVBA.bas file is not
available for import, it may be exported from the sample
spreadsheet provided in the downloaded file. With all 2D
font packages, such as QR-Code and Data-Matrix, the .bas
file will reside in the product zip file.

Importing:

Windows:
- Excel 2010 and above: Add
  
  Developer tab, if not already there. Go to
  
  File — Options — Customize Ribbon,
  select
  
  Developer under Main Tabs on the right-hand
  side, and click OK. Now go to
  
  Developer — Visual Basic — File — Import File.
  
  Step-by-Step Instructions
- Excel 2007: Add
  
  Developer tab, if not already there. Right
  Click on the
  
  Office button in upper left corner of Excel
  screen and choose
  
  Customize Quick Access Toolbar. Click on
  
  Popular at the top of the list on the left
  and then click
  
  Show Developer Tab
  
  in the Ribbon and save. Now go to Developer
  — Visual Basic — File — Import File
- Excel 1997-2003: Select
  
  Tools — Macro — Visual Basic Editor.
Mac:
- Excel for Mac 2004 and above*: Office
  for Mac does not have an import feature in the 2004
  version; therefore, users must copy and paste the
  necessary RTF file, which are available by request
  after purchase of a
  
  Universal Barcode Font license, manually by
  going to
  
  Tools — Macros — Visual Basic Editor.
  - Once the editor window is open, go to
    
    Insert — Module and paste the contents of the RTF file for the corresponding type barcode being used.
- Excel for Mac 2011: Office for Mac has included an import feature in their 2011 version.
  Go to
  
  Tools — Macro — Visual Basic Editor.
  - Choose the IDAutomation VBA.bas file by
    right-clicking and selecting Import File.
    
    Step-by-Step Instructions

Very
Important: Regardless of the Excel version, after
importing the .bas file, immediately save the Excel file
as an Excel Macro-Enabled
Workbook.

*Note: The Visual Basic Editor feature
was removed from Excel for Mac 2008, and thus this
font tool cannot be used in that environment.

Exporting:

Windows:
- Choose
  
  Tools — Macro — Visual Basic Editor.
- Within the editor, choose
  
  View — Project Explorer.
- Highlight
  
  IDAutomationVBA within the Modules folder
  and choose
  
  File — Export File.
- Name for the exported file
  
  IDAutomationVBA.bas.

Importing and Exporting Macros &
VBA in Access

The VBA code, functions, and Macros reside inside the access
database as a VBA module. To use the functions in another Access
database, the module must be copied to the other database, or
the module must be exported from the sample database and imported
into the other database.

Copy the Module to Another Database: Choose the

Modules folder. Highlight the

IDAutomationVBA module and choose

File — Save As. Save the module to an external file.
Choose the database to copy the module to and click

OK. This option is not available in all versions
of Access.
Exporting:
Choose the

Modules folder. Highlight the

IDAutomationVBA module and select

File — Save As. Save the module to an external file
named

IDAutomationVBA.
Importing:

Access 2007 and above: Select the

Database Tools tab — Visual Basic.
Choose the

Modules folder. Select the

IDAutomationVBA file and save the module when asked.

Access 2000 — 2003: Select

Tools — Macro — Visual Basic Editor.

Excel VBA Barcode Generation Tutorial

Before starting, ensure that these VBA Macros will achieve
the desired goal. If uncertain, consult the
Excel Barcode Integration
Guide for a variety of scenarios and product suggestions.
After downloading the file and extracting its contents, open
the sample Excel spreadsheet provided. This spreadsheet contains
some examples of various barcode types. A VBA module is included
in the sample spreadsheet that contains custom functions and
Macros that format data to IDAutomation’s barcode fonts.
Use the sample spreadsheet as a reference for creating barcodes
if help is needed, or

contact IDAutomation for additional support.

«I found good documentation on your product,
and clearly defined license terms. Your web site is
well designed and has a wealth of information. We have
been able to implement barcoded data collection and
reporting. The barcode font has enabled us to streamline
our data collection process significantly. It was extremely
simple to set up. We use the Microsoft Excel Macro to
create internal forms that can easily be scanned throughout
our manufacturing process.»
— Thomas Bell, Cynosure,
Westford, MA

How to Create a Barcode in Excel

Enable the
security setting that allows Macros to run. If prompted
when the document re-opens, choose

Enable Macros.
- Office 2007 and above applications require
  the Macros to
  
  run from a trusted location.
- Office 2004 and 2011 for Mac settings are
  located at Excel — Preferences — Security
  — Macro Security.
- Excel 2000 and 2003 require a medium-security
  setting to run Macros. Open Excel and set the security
  level to medium by choosing Tools — Macro
  — Security.
- Signed Macros are included in the latest
  version of the
  VBA Module download. Simply choose the
  
  Trust this Publisher option and the VBA Macros will run unprompted. Data may be pasted into these files and used if the Macros are not modified.
If a different spreadsheet is used other than the sample
provided, the Macros must be imported
into the spreadsheet.
Create a column in the spreadsheet for the barcode.
Size the column to make sure it is wide enough to contain
the entire barcode.
Format the column so that any text appearing in it will
be centered. This is necessary to create the white space
(often called the quiet zone) before and after the barcode.
Enter the formula in this cell that will format the data to the barcode font. If unsure which
function or barcode to use, consider
the

Code 128 barcode fonts with the

=Code128(B10,0) function where «B10»
refers to the cell location of the data that is to be encoded
and the «,0»
formats the result of the formula to the Code 128 fonts.
For all 2D fonts, refer to the documentation within that
particular package.
Examine the spreadsheet to make sure the data is being properly formatted to the barcode font. Strange characters may append to the beginning and end of the data from the fields, but this is normal. In some cases, the data may need to be reformatted and may appear scrambled. This is normal for Code 128 and Interleaved 2 of 5 barcode fonts when numbers need to be compressed within the barcode.
After verifying that the text in the cell has been formatted
correctly, select the appropriate font and set the point
size to 12. This example selects the

IDAutomationC128XS font. The XS and S sizes of IDAutomation’s
fonts in

Code 128 and

Code 39 are specifically designed to format correctly
in Excel, as larger fonts will not usually format correctly
in the cell. 2D symbols within Excel directly are only possible
with the

2D XLS font for Excel.
Ensure that the column is wide enough to contain the
entire barcode with some white space before and after the
barcode.
Scan the printed barcodes with a
handheld USB barcode scanner to verify the correct data
is encoded.

Symbology-Specific Tutorials for Excel:

2D Barcodes:

Aztec
Data Matrix
PDF417
QR Code

Linear Barcodes:

Code 128
Code 128 for Mac using Universal Fonts
GS1-128 using Code 128 Fonts
GS1-128 using the GS1 Fonts
Interleaved 2 of 5
GS1 DataBar
Universal Fonts
USPS IMb (Intelligent Mail)
UPC/EAN

Barcoding an Entire Column
in Excel

IDAutomation’s barcode fonts and Macros provide an easy
method of barcoding a column in Excel. In this example, Code
128 barcodes are created in Column B from data in Column A.
This example assumes the

Code 128 Barcode Font Package has been installed, and the
VBA module has been imported into the spreadsheet.

Enter the formula in one cell to format the data to
the barcode font as explained in the Barcode
Tutorial for Excel:
Select that cell and choose Edit — Copy.
At this point, it may be necessary to deselect any cells not needed for barcoding. Then, highlight an entire column by selecting the gray square letter-labeled area at the top of the spreadsheet and choose Edit — Paste. In
this example, the button is marked

B. If the spreadsheet is large, the formulas may
take some time to paste and re-calculate if the spreadsheet
is large.
Change the column to the appropriate barcode font. In
this example, choose the

IDAutomationC128XS font while the entire column that contains the formula is selected. The barcodes will appear in the entire column. When displaying 2D barcodes in Excel
such as QR-Code, Data Matrix, or PDF417, use the

2D XLS Font specifically designed for Excel at 8 points.
Confirm that the barcodes are accurate by scanning them
from printed sheets, or directly from the screen. IDAutomation
offers a variety of
barcode readers
that can perform this function with ease.

Video Tutorials

Video:
How to Extract the IDAutomation VBA for Excel
Video:
How to Import the IDAutomation VBA into Excel
Video: How to Create a Barcode in Excel for Windows
Video:
How to Create a Barcode on Mac Excel 2004

Access VBA Macro Barcode Functions Tutorial

After
the appropriate files have been downloaded and extracted, open
the sample Access database provided. This database contains
one table, one module, and some sample reports. The module contains
custom VBA code, functions, and Macros. The sample database should
be used as a reference if help is needed.

How to Create Barcodes in an Access Report

Before starting this tutorial, ensure that
VBA Macros are the desired implementation. Several methods of
creating barcodes in Access are explained in the

Barcode Integration Guide for Microsoft Access.

If a different database is being used and not the sample
provided, first import the VBA Macros
into the database.
The most recent versions of Access require a
medium security setting to run Macros.
- Open Access and set the security level to medium
  by choosing
  
  Tools — Macro — Security.
- If prompted when the document is reopened, select
  
  Enable Macros.
  Office 2007 and above
  may require that the Macros
  
  run from a trusted location. Signed Macros are included
  in the latest version of the
  VBA download. Simply choose the
  
  Trust this Publisher option and the VBA Macros
  will run unprompted. Tables, Reports, Forms and other
  information may be pasted into these files and used
  if the Macros are not modified.
Open a report in Design Mode.
Create a text box where the barcode will display.
To format the data to the desired barcode font in a
text box, a function must be placed in the Control Source
specifying the data field that needs to be encoded.
- The formula
  
  =function([field]) should be entered
  in the Control Source property of the text box, for
  example:
```
=Code128([Serial])
```
- In some cases, it may be necessary to specify the
  table and field in the control source, for example:
```
=Code128([Table1.Field1])
```
  If unsure of which function to
  use, consider the
  
  =Code128([field]) function with
  
  Code 128 Barcode Fonts.
- Optional: The Control Source may be changed
  to a formula that appends text to the data or combines
  multiple fields, for example:
```
=Code128("PREFIX" & [Field1]) 
```
  or
```
=Code128([Field1] & [Field2])
```
  or
```
=Code128([Field1] & "," & [Field2])
```
- In Code 128, the
  ApplyTilde feature may also be used to encode tab
  and return functions. For example, the following formula
  creates a tab function between two fields:
```
=Code128([Field1] & "~009" & [Field2],0,True)
```
Run
the report to make sure the data is being populated from
the fields and formatted to the barcode font. Strange characters may append to the beginning and end of the data, but
this is normal. In some cases, the data may need to be reformatted
and it may appear to be scrambled. This is normal for Code
128, Interleaved 2 of 5, DataBar and 2D barcodes.
Change the formula field font to the appropriate barcode font and set the point size to 12. If this step is not followed,
generated barcodes will not display.
Print and scan the barcodes to verify that the correct
data is encoded. If a scanner is needed to verify barcodes,
consider the

IDAutomation USB Barcode Scanner.

Note: When distributing Access Databases, the associated barcode font must be installed on each computer that prints the barcodes. If this is inconvenient, the

Native Barcode Generator for Access is a complete barcode
generator object that stays embedded in the database, which
means no fonts need to be installed on user computers. For more
information about other methods of barcoding in Access, please
refer to the

Microsoft Access Barcode Integration Guide.

If a large amount of data needs to be encoded, the

PDF417 Barcode Font and Encoder or the

Data Matrix Barcode Font and Encoder may be the best options
as these 2D barcode types allow for the encoding of more data.

Video Tutorial Create a Barcode in Access
2010 and above

VBA & Macro Functions in Microsoft Word Mail-Merge

Before starting this barcode tutorial, ensure VBA Macros
are the desired implementation for a Word mail-merge. An easier
method exists when using Codabar or Code 39 fonts, and this
is explained further in the

Barcode Integration Guide for Microsoft Word.

Excel must be used as the data source when creating barcodes in a Microsoft Word mail merge using Macros. The field used
for the data source in Word should be the column in Excel where
the formula has been applied, which is used to format the data
to the barcode font. It is best to use the last column of the
spreadsheet in order to avoid merging conflicts.

To set up an Excel spreadsheet with these barcode Macros,
refer to the Barcode Tutorial for Excel.

Note:

C128 ReturnTypes 6 through 9 are not currently supported
in Excel-Word mail-merges.

Excel 2000 and 2003 require a
medium security setting to run Macros. Open Excel and
set the security level to medium by choosing

Tools — Macro — Security.
Office 2007
and above may require the Macros to

run from a trusted location.
In Office 2004 for
Mac, go to

Excel — Preferences — Security and select

Macro Security to enable the secure setting.
After the files have been downloaded and extracted,
open the included Word Mail-Merge document. A message may
appear stating that the data source cannot be found. If
so, select

Data Source for Word Mail Merge.xls as the data source.
If asked, enable Macros.
The formula may be viewed in the cells of the

Barcode column in the Excel spreadsheet. This formula
retrieves the data to encode and passes it to the appropriate
barcode function. The function will
then format the data to the barcode font. This column is
then passed to Word when the mail merge is started. The
appropriate barcode font must be selected for the field
in MS Word; in this case, it is

«Barcode».
The barcode will not look correct and will not scan
until the mail merge is performed.
After the merge is performed, print and scan the barcode
to verify that the correct data has been encoded. If a scanner
is needed to verify barcodes, IDAutomation suggests easy-to-use

USB Barcode Scanners.
When distributing the mail merge, the font should be embedded in Word and the Excel data source
must be accessible.

VBA Barcode Macro Functions and Properties

The functions listed below are available in IDAutomation’s

IDAutomationVBA.bas file and are only valid when used with the font listed in the «font to use» column.
Functions beginning with

IDAutomation_Uni_ may only be used with the

IDAutomation Universal Barcode Font Advantage™ package
and are supplied in the

IDAutomationWindowsDLLVBA.bas file provided within that
package.

Linear Functions
Universal Functions
DataBar Functions

DataToEncode is the string data type for all functions
listed below. Other data types such as numbers or dates may
need to be converted to the string data type to be properly
encoded. Additional parameters are available for some functions and are optional. For example, Code128(«123456»,0,True).
For UPC-A, UPC-E & EAN-13, the +2 and +5 add-on codes may
be created by adding the digits to the end of the data being
encoded.

VBA Functions for Standard Barcode Fonts
Barcode Type	Barcode Function Methods \| Notes	VBA File to Import	Required Font
Code-11	Code11 (DataToEncode)	IDAutomationVBA.bas	IDAutomationC11
Code-128 (Auto Mode)	Code128 (DataToEncode, C128 ReturnType, ApplyTilde) Human Readable text is enabled when ReturnType = 6 Example: Code128(«123456789012», 6, 0)	IDAutomationVBA.bas or IDAutomation VBA for Code 128 and Postnet.bas*	IDAutomationC128
Code-128 (Manual Mode)	IDAutomation recommends using Auto Mode for most situations. Code128a (DataToEncode, C128 ReturnType) Code128b (DataToEncode, C128 ReturnType) Code128c (DataToEncode, C128 ReturnType) Example: Code128b(«12345678», 6)	IDAutomationVBA.bas or IDAutomation VBA for Code 128 and Postnet.bas*	IDAutomationC128
Code-39	Code39 (DataToEncode) Code39Mod43 (DataToEncode, ReturnType) Example: Code39Mod43(«12345678», 0)	IDAutomationVBA.bas	IDAutomationC39
Code-93	Code93 (DataToEncode)	IDAutomationVBA.bas	IDAutomationC93
Codabar	Codabar (DataToEncode)	IDAutomationVBA.bas	IDAutomationCB
EAN-13	IDAEAN13 (DataToEncode)	IDAutomationVBA.bas	IDAutomationUPCEAN
EAN-8	IDAEAN8 (DataToEncode)	IDAutomationVBA.bas	IDAutomationUPCEAN
GS1-128	Code128 (DataToEncode, C128 ReturnType, 1) GS1-128 is enabled in Code 128 Auto by setting ApplyTilde to True. Human Readable AIs may be created by setting the C128 ReturnType to 6. Example: Code128(«(12)3456789012», 6, 1)	IDAutomationVBA.bas or IDAutomation VBA for Code 128 and Postnet.bas*	IDAutomationC128
Interleaved 2 of 5	I2of5 (DataToEncode) I2of5Mod10 (DataToEncode, ReturnType) Example: I2of5Mod10(«123456789», 1) NOTE: ReturnType 3 generates an OPC (Optical Product Code) symbol. OPC is also known as Vision Council of America OPC, VCA BarCode & VCA OPC. Example: I2of5Mod10(«020748721», 3)	IDAutomationVBA.bas	IDAutomationI25
MSI / Plessey	MSI (DataToEncode, ReturnType)	IDAutomationVBA.bas	IDAutomationMSI
RM4SCC	RM4SCC (DataToEncode)	IDAutomationVBA.bas	IDAutomationRM
UPC-A	UPCa (DataToEncode)	IDAutomationVBA.bas	IDAutomationUPCEAN
UPC-E	UPCe (DataToEncode)	IDAutomationVBA.bas	IDAutomationUPCEAN
USPS IntelligentMail (IMb)	IntelligentMail (DataToEncode) ** Included only in the purchased version of the USPS IMb Font Package.	IDAutomation VBA for Intelligent Mail.bas	IDAutomationPOSTNET or IDAutomationIMB
USPS Postnet	Postnet (DataToEncode, ReturnType) *Included in Postnet package.	IDAutomationVBA.bas or IDAutomation VBA for Code 128 and Postnet.bas*	IDAutomationPOSTNET
USPS Planet	Planet (DataToEncode, ReturnType)	IDAutomationVBA.bas or IDAutomation VBA for Code 128 and Postnet.bas*	IDAutomationPOSTNET
not applicable	MOD10 (DataToEncode)	IDAutomationVBA.bas	not applicable
not applicable	SpliceText (DataToEncode, SpacingNumber, ApplyTilde)	IDAutomationVBA.bas	not applicable
Functions for the Universal Barcode Font
All functions listed below are preceded with IDAutomation_Uni_.* They may only be used with the IDAutomation Universal Barcode Font Advantage™ and are supplied in the IDAutomation_UniversalFont_VBA.bas or the IDAutomationWindowsDLLVBA.bas file which also requires the installation of the product EXE file in order for the macro to function, because they access an installed IDAutomationNativeFontEncoder.dll that is provided within the package. Note: Excel 2004 for Mac requires the functions to be lowercase. Ex: idautomation_uni_c128
Barcode Type	Universal Function Methods \| Notes	VBA File to Import	Required Font
Code-128	IDAutomation_Uni_C128 (DataToEncode, ApplyTilde) Note: Code128() is the recommended method to use. Code128() is also used to create GS1-128. IDAutomation_Uni_C128A (DataToEncode) IDAutomation_Uni_C128B (DataToEncode) IDAutomation_Uni_C128C (DataToEncode) Example: IDAutomation_Uni_C128 («Ê8100712345Ê2112WH5678», TRUE) Excel for Mac: idautomation_uni_c128 («Ê8100712345Ê2112WH5678», TRUE)	IDAutomation_UniversalFont_VBA.bas or IDautomation_WindowsDLLVBA.bas and IDAutomationNativeFontEncoder.dll	IDAutomation_Uni
not applicable	C128HR (DataToEncode, ApplyTilde) Returns text for Code 128 barcodes, such as for GS1-128.	IDAutomation_UniversalFont_VBA.bas or IDautomation_WindowsDLLVBA.bas and IDAutomationNativeFontEncoder.dll	Text Font
Code-39	IDAutomation_Uni_C39 (DataToEncode, N_Dimension, IncludeCheckDigit) Example: IDAutomation_Uni_C39 («123456789», 3, TRUE ) Excel for Mac: idautomation_uni_c39 («123456789», 3, TRUE )	IDAutomation_UniversalFont_VBA.bas or IDautomation_WindowsDLLVBA.bas and IDAutomationNativeFontEncoder.dll	IDAutomation_Uni
Codabar	IDAutomation_Uni_Codabar (DataToEncode, N_Dimension, StartChar, StopChar) Example: IDAutomation_Uni_Codabar («123456789″, 3,»A»,»B» ) Excel for Mac: idautomation_uni_codabar («123456789″, 3,»A»,»B» )	IDAutomation_UniversalFont_VBA.bas or IDautomation_WindowsDLLVBA.bas and IDAutomationNativeFontEncoder.dll	IDAutomation_Uni
Interleaved 2 of 5	IDAutomation_Uni_I2of5 (DataToEncode, N_Dimension, IncludeCheckDigit)	IDAutomation_UniversalFont_VBA.bas or IDautomation_WindowsDLLVBA.bas and IDAutomationNativeFontEncoder.dll	IDAutomation_Uni
MSI / Plessey	IDAutomation_Uni_MSI (DataToEncode, N_Dimension, IncludeCheckDigit)	IDAutomation_UniversalFont_VBA.bas or IDautomation_WindowsDLLVBA.bas and IDAutomationNativeFontEncoder.dll	IDAutomation_Uni
USPS IntelligentMail	IDAutomation_Uni_IntelligentMail (DataToEncode) **	IDAutomation_UniversalFont_USPS_IMb_VBA.bas	IDAutomation_Uni
USPS Postnet	IDAutomation_Uni_Postnet (DataToEncode, IncludeCheckDigit)	IDAutomation_UniversalFont_VBA.bas or IDautomation_WindowsDLLVBA.bas and IDAutomationNativeFontEncoder.dll	IDAutomation_Uni
USPS Planet	IDAutomation_Uni_Planet (DataToEncode, IncludeCheckDigit)	IDAutomation_UniversalFont_VBA.bas or IDautomation_WindowsDLLVBA.bas and IDAutomationNativeFontEncoder.dll	IDAutomation_Uni
Functions for the DataBar Barcode Font
The functions listed below are preceded with IDAutomation_GS1 and are only provided with the IDAutomation DataBar Font Advantage Package.
Barcode Type	DataBar Barcode Function Methods \| Notes	VBA File to Import	Required Font
DataBar	DataBar (DataToEncode)	IDAutomationGS1DataBar.bas	IDAutomation DataBar 34
DataBar Expanded	DataBarExpanded (DataToEncode, 22)	IDAutomationGS1DataBar.bas	IDAutomation DataBar 34
DataBar Exp. Stacked	DataBarExpanded (DataToEncode, Segments)	IDAutomationGS1DataBar.bas	IDAutomation DataBar 34
DataBar Stacked Omnidirectional	DataBarStacked (DataToEncode)	IDAutomationGS1DataBar.bas	IDAutomation DataBar 34
The functions listed below are rare and not approved for POS systems.
DataBar Limited	DataBarLimited (DataToEncode) (Not approved for POS)	IDAutomationNativeWindowsDLLVBA.bas and IDAutomationNativeFontEncoder.dll	IDAutomation DataBar 13
DataBar Stacked	DataBarStacked (DataToEncode) (Not approved for POS)	IDAutomationNativeWindowsDLLVBA.bas and IDAutomationNativeFontEncoder.dll	IDAutomation DataBar 13
DataBar Truncated	DataBar (DataToEncode) (Not approved for POS)	IDAutomationNativeWindowsDLLVBA.bas and IDAutomationNativeFontEncoder.dll	IDAutomation DataBar 13
2D Font Functions
Regarding all symbologies listed in this section below: VBA code for these functions will be provided within each package of the purchased 2D font product. Symbology options and parameter changes to functions listed below may be made within the code of the function itself.
Barcode Type	2D Function Methods \| Notes	VBA File to Import	Required Font
Data Matrix	IDAutomation_DMatrix_FontEncoder(ByVal DataToEncode As String, Optional ApplyTilde As Integer = 1, Optional EncMode As Integer = -1,Optional preferredFormat As Integer = -1, Optional NewLineCharacter As String = vbCrLf) As String Complete VBA is only provided in the purchased version.	IDAutomation_VBA_DataMatrix_FE2021.bas (2021 Release)	IDAutomation2D or IDAutomationDMatrix
EncNDM(DataToEncode As String, Optional ApplyTilde As Integer = 0, Optional EncodingMode As Integer = 0, Optional preferredFormat As Integer = -1) As String	IDAutomation_Native_DataMatrix_Mac.rtf
QR-Code	IDAutomation_QRFontEncoder(DataToEncode) All parameters are set to default except ApplyTilde which is set to 1.	IDAutomation_VBA_QRCode_FE2021 (2021 Release)	IDAutomation2D
PDF417	IDAutomation_PDF417(DataToEncode As String, Optional EccLevel As Integer, Optional ColumnSpecify As Integer, Optional RowSpecify As Integer, Optional Truncate As Integer, Optional ForceBinary As Integer) As String	IDAutomation_Native_PDF417_Macro.bas	IDAutomation2D or IDAutomationPDF417
IDAutomation_PDF417(DataToEncode As String, Optional EcLevel As Integer, Optional TotalColumns As Integer, Optional TotalRows As Integer, Optional Truncated As Integer, Optional PDFMode As Integer, Optional ApplyTilde As Integer) As String	IDAutomation_PDF417_Macro.bas and IDAutomationPDF417.dll (Legacy ActiveX Version)
Aztec	EncAztec(DataToEncode As String, Optional ProcessTilde, Optional Error Correction)	IDAutomation_Aztec_Macro.bas and IDAutomationAztec.dll	IDAutomation2D
Maxicode	EncMC(DataToEncode as String, Optional EncodingMode as Int) The default Encoding Mode is 2	IDAutomation_MaxiCode_Macros.bas	IDAutomation Maxicode

Barcode Function Descriptions

ApplyTilde: If set to «1»
or «True», characters following the tilde may
be used to

perform additional calculations or

encode ASCII characters directly.
DataToEncode: This string
value represents the data being encoded.
N_Dimension: Determines the width of the wide bars when applicable, which is a multiple of the X dimension. Valid values are 2, 2.5 and 3. The default is 2. The X dimension is determined by the font point size.
IncludeCheckDigit:
A Boolean value that determines whether a check digit should
be automatically calculated and included for the DataToEncode.
Segments: Reducing segments
to a low, even number such as 4, 6 or 8 in a DataBar Expanded
symbol can create a

stacked barcode. The default is 22.

** The

USPS Intelligent Mail (IMb) function is supplied in pure
VBA code with the purchased version of the associated font package.

Источник

Представляю Вашему вниманию огромный сборник макросов и функций, все макросы сгруппированы по главам, для удобства добавил оглавление с гиперссылками.

P.S.: Где скачал не помню.

Запуск макроса с поиском ячейки
Запуск макроса при открытии книги
Запуск макроса при вводе в ячейку «2»
Запуск макроса при нажатии «Ентер»
Добавить в панель свою вкладку «Надстройки» (Формат ячейки)

Проверка наличия файла по указанному пути_1
Проверка наличия файла по указанному пути_2
Проверка наличия файла по указанному пути_3
Поиск нужного файла_1
Поиск нужного файла_2
Поиск нужного файла_3
Поиск нужного файла_4
Автоматизация удаления файлов
Произвольный текст в строке состояния
Восстановление строки состояния
Бегущая строка в строке состояния
Быстрое изменение заголовка окна
Быстрое изменение заголовка окна_2
Изменение заголовка окна (со скрытием названия файла)
Возврат к первоначальному заголовку
Что открыто в данный момент
Работа с текстовыми файлами
Запись и чтение текстового файла
Обработка нескольких текстовых файлов
Определение конца строки текстового файла
Копирование из текстового файла в эксель
Копирование содержимого в текстовый файл_1
Копирование содержимого в текстовый файл_2
Экспорт данных в HТМL
Создание резервных копий ценных файлов
Подсчет количества открытий файла
Вывод пути к файлу в активную ячейку
Копирование содержимого файла RTF в эксель
Копирование данных из закрытой книги
Извлечение данных из закрытого файла
Поиск слова в файлах
Создание текстового файла и ввод текста в файл
Создание текстового файла и ввод текста (определение конца файла)
Создание документов Word на основе таблицы Excel
Команды создания и удаления каталогов
Получение текущего каталога
Посмотреть все файлы в каталоге_1
Посмотреть все файлы в каталоге_2
Посмотреть все файлы в каталоге_3

Количество имен рабочей книги
Защита рабочей книги
Запрет печати книги
Открытие книги (или текстовых файлов)
Открытие книги и добавление в ячейку А1 текста
Сколько книг открыто
Закрытие всех книг
Закрытие рабочей книги только при выполнении условия
Сохранение рабочей книги с именем, представляющим собой текущую дату
Сохранена ли рабочая книга
Создать книгу с одним листом
Удаление ненужных имен
Быстрое размножение рабочей книги
Сортировка листов
Поиск максимального значения на всех листах книги
Проверка наличия защиты рабочего листа
Список отсортированных листов
Создать новый лист_1
Копирование листа в книге
Копирование листа в новую книгу (создается)
Перемещение листа в книге
Перемещение нескольких листов в новую книгу
Заменить существующий файл
Вставка колонтитула с именем книги, листа и текущей датой
Существует ли лист
Существует ли лист_2
Вывод количества листов в активной книге
Вывод количества листов в активной книге в виде гиперссылок
Вывод имен активных листов по очереди
Вывод имени и номеров листов текущей книги
Сделать лист невидимым
Сколько страниц на всех листах?
Копирование строк на другой лист
Копирование столбцов на другой лист
Подсчет количества ячеек, содержащих указанные значения_1
Подсчет количества ячеек в диапазоне, содержащих указанные значения_2
Подсчет количества видимых ячеек в диапазоне
Определение количества ячеек в диапазоне и суммы их значений
Подсчет количества ячеек
Автоматический пересчет данных таблицы при изменении ее значений
Ввод данных в ячейки
Ввод данных с использованием формул
Ввод текстоввых данных в ячейки
Вывод в ячейки названия книги, листа и количества листов
Удаление пустых строк_1
Удаление пустых строк_2
Удаление пустых строк_3
Удаление строки по условию
Удаление используемых скрытых строк или строк с нулевой высотой
Удаление дубликатов по маске
Выделение диапазона над текущей ячейкой
Выделение диапазона над текущей ячейкой_2
Выделение отрицательных значений
Выделение диапазона и использование абсолютных адресов
Выделение ячеек через интервал_2
Движение по ячейкам
Поиск ближайшей пустой ячейки столбца
Поиск максимального значения
Поиск и замена по шаблону
Поиск значения с отображением результата в отдельном окне
Поиск с выделением найденных данных_1
Поиск с выделением найденных данных_2
Поиск по условию в диапазоне
Поиск последней непустой ячейки диапазона
Поиск последней непустой ячейки столбца
Поиск последней непустой ячейки строки
Поиск ячейки синего цвета в диапазоне
Поиск наличия значения в столбце
Поиск совпадений в диапазоне
Поиск ячейки в диапазоне_1
Поиск ячейки в диапазоне_2
Поиск приближенного значения в диапазоне
Поиск начала и окончания диапазона, содержащего данные
Автоматическая замена значений
Быстрое заполнение диапазона (массив)
Заполнение через интервал(массив)
Заполнение указанного диапазона(массив)
Заполнение диапазона(массив)
Расчет суммы первых значений диапазона
Размещение в ячейке электронных часов
«Будильник»
Адрес активной ячейки
Координаты активной ячейки
Формула активной ячейки
Получение из ячейки формулы
Тип данных ячейки
Вывод адреса конца диапазона
Получение информации о выделенном диапазоне
Создание изменяемого списка (таблица)
Умножение выделенного диапазона на 2
Одновременное умножение всех данных диапазона
Деление диапазона на 100
Суммирование данных только видимых ячеек
Сумма ячеек с числовыми значениями
При суммировании — курсор внутри диапазона
Начисление процентов в зависимости от суммы_1
Начисление процентов в зависимости от суммы_2
Начисление процентов в зависимости от суммы_3
Сводный пример расчета комиссионного вознаграждения
Движение по диапазону
Сдвиг от выделенной ячейки
Создание заливки диапазона
Подбор параметра ячейки
Разбиение диапазона
Объединение данных диапазона
Объединение данных диапазона_2
Узнать максимальную колонку или строку.
Ограничение возможных значений диапазона
Тестирование скорости чтения и записи диапазонов
Открыть MsgBox при выборе ячейки
Скрытие строки
Скрытие нескольких строк
Скрытие столбца
Скрытие нескольких столбцов
Скрытие строки по имени ячейки
Скрытие нескольких строк по адресам ячеек
Скрытие столбца по имени ячейки
Скрытие нескольких столбцов по адресам ячеек
Мигание ячейки

Вывод на экран всех примечаний рабочего листа
Функция извлечения комментария
Список примечаний защищенных листов
Перечень примечаний в отдельном списке_1
Перечень примечаний в отдельном списке_2
Перечень примечаний в отдельном списке_3
Подсчет количества примечаний_1
Подсчет примечаний_3
Выделение ячеек с примечаниями
Отображение всех примечаний
Изменение цвета примечаний
Добавление примечаний
Добавление примечаний в диапазон по условию
Перенос комментария в ячейку и обратно
Перенос значений из ячейки в комментарий_1
Перенос значений из ячейки в комментарий_2

Дополнение панели инструментов
Добавление кнопки на панель инструментов
Панель с одной кнопкой
Панель с двумя кнопками
Создание панели справа
Вызов предварительного просмотра
Создание пользовательского меню (вариант 1)
Создание пользовательского меню (вариант 2)
Создание пользовательского меню (вариант 3)
Создание пользовательского меню (вариант 4)
Создание пользовательского меню (вариант 5)
Создание списка пунктов главного меню Excel
Создание списка пунктов контекстных меню
Отображение панели инструментов при определенном условии
Скрытие и отображение панелей инструментов
Создать подсказку к моим кнопкам
Создание меню на основе данных рабочего листа
Создание контекстного меню
Блокировка контекстного меню
Добавление команды в меню Сервис
Добавление команды в меню Вид
Создание панели со списком
Мультфильм с помощником в главной роли
Дополнение помощника текстом, заголовком, кнопкой и значком
Новые параметры помощника
Использование помощника для выбора цвета заливки

Функция INPUTBOX (через ввод значения)
Настройка ввода данных в диалоговом окне
Открытие диалогового окна (“Открыть файл”)_1
Вызов броузера из Экселя
Диалоговое окно ввода данных
Значения по умолчанию

Вывод списка доступных шрифтов
Выбор из текста всех чисел
Прописная буква только в начале текста
Подсчет количества повторов искомого текста
Выделение из текста произвольного элемента
Отображение текста «задом наперед»
Запуск таблицы символов из Excel

Получить имя пользователя
Вывод разрешения монитора
Получение информации об используемом принтере
Просмотр информации о дисках компьютера

Построение диаграммы с помощью макроса
Сохранение диаграммы в отдельном файле
Построение и удаление диаграммы нажатием одной кнопки
Применение случайной цветовой палитры
Эффект прозрачности диаграммы
Построение диаграммы на основе данных нескольких рабочих листов
Создание подписей к данным диаграммы

Программа для составления кроссвордов
Игра «Минное поле»
Игра «Угадай животное»
Расчет на основании ячеек определенного цвета

Вызов функциональных клавиш
Расчет среднего арифметического значения
Перевод чисел в «деньги»
Поиск ближайшего понедельника
Подсчет количества полных лет
Расчет средневзвешенного значения
Преобразование номера месяца в его название
Использование относительных ссылок
Преобразование таблицы Excel в HТМL-формат
Генератор случайных чисел
Случайные числа — на основании диапазона
Применение функции без ввода ее в ячейку
Подсчет именованных объектов
Включение автофильтра с помощью макроса
Создание бегущей строки
Создание бегущей картинки
Вращающиеся автофигуры
Вызов таблицы цветов
Создание калькулятора
Склонение фамилии, имени и отчества

Вывод даты и времени_1
Вывод даты и времени_2
Получение системной даты
Извлечение даты и часов
Функция ДатаПолная

К сообщению приложен файл: macros.rar (83Kb)

ГЛАВА 1. МАКРОСЫ

Запуск макроса с поиском ячейки

Запуск макроса при открытии книги

Запуск макроса при вводе в ячейку «2»

Запуск макроса при нажатии «Ентер»

Добавить в панель свою вкладку «Надстройки» (Формат ячейки)

ГЛАВА 2. РАБОТА С ФАЙЛАМИ (Т.Е.ОБМЕН ДАННЫМИ С ТХТ, RTF, XLS И Т.Д.)

Проверка наличия файла по указанному пути_1

Проверка наличия файла по указанному пути_2

Проверка наличия файла по указанному пути_3

Поиск нужного файла_1

Поиск нужного файла_2

Поиск нужного файла_3

Поиск нужного файла_4

Автоматизация удаления файлов

Произвольный текст в строке состояния

Восстановление строки состояния

Бегущая строка в строке состояния

Быстрое изменение заголовка окна

Быстрое изменение заголовка окна_2

Изменение заголовка окна (со скрытием названия файла)

Возврат к первоначальному заголовку

Что открыто в данный момент

Работа с текстовыми файлами

Запись и чтение текстового файла

Обработка нескольких текстовых файлов

Определение конца строки текстового файла

Копирование из текстового файла в эксель

Копирование содержимого в текстовый файл_1

Копирование содержимого в текстовый файл_2

Экспорт данных в HТМL

Создание резервных копий ценных файлов

Подсчет количества открытий файла

Вывод пути к файлу в активную ячейку

Копирование содержимого файла RTF в эксель

Копирование данных из закрытой книги

Извлечение данных из закрытого файла

Поиск слова в файлах

Создание текстового файла и ввод текста в файл

Создание текстового файла и ввод текста (определение конца файла)

Создание документов Word на основе таблицы Excel

Команды создания и удаления каталогов

Получение текущего каталога

Посмотреть все файлы в каталоге_1

Посмотреть все файлы в каталоге_2

Посмотреть все файлы в каталоге_3

ГЛАВА 3. РАБОЧАЯ ОБЛАСТЬ MICROSOFT EXCEL

Количество имен рабочей книги

Защита рабочей книги

Запрет печати книги

Открытие книги (или текстовых файлов)

Открытие книги и добавление в ячейку А1 текста

Сколько книг открыто

Закрытие всех книг

Закрытие рабочей книги только при выполнении условия

Сохранение рабочей книги с именем, представляющим собой текущую дату

Сохранена ли рабочая книга

Создать книгу с одним листом

Удаление ненужных имен

Быстрое размножение рабочей книги

Сортировка листов

Поиск максимального значения на всех листах книги

Проверка наличия защиты рабочего листа

Список отсортированных листов

Создать новый лист_1

Копирование листа в книге

Копирование листа в новую книгу (создается)

Перемещение листа в книге

Перемещение нескольких листов в новую книгу

Заменить существующий файл

Вставка колонтитула с именем книги, листа и текущей датой

Существует ли лист

Существует ли лист_2

Вывод количества листов в активной книге

Вывод количества листов в активной книге в виде гиперссылок

Вывод имен активных листов по очереди

Вывод имени и номеров листов текущей книги

Сделать лист невидимым

Сколько страниц на всех листах?

Копирование строк на другой лист

Копирование столбцов на другой лист

Подсчет количества ячеек, содержащих указанные значения_1

Подсчет количества ячеек в диапазоне, содержащих указанные значения_2

Подсчет количества видимых ячеек в диапазоне

Определение количества ячеек в диапазоне и суммы их значений

Подсчет количества ячеек

Автоматический пересчет данных таблицы при изменении ее значений

Ввод данных в ячейки

Ввод данных с использованием формул

Ввод текстоввых данных в ячейки

Вывод в ячейки названия книги, листа и количества листов

Удаление пустых строк_1

Удаление пустых строк_2

Удаление пустых строк_3

Удаление строки по условию

Удаление используемых скрытых строк или строк с нулевой высотой

Удаление дубликатов по маске

Выделение диапазона над текущей ячейкой

Выделение диапазона над текущей ячейкой_2

Выделение отрицательных значений

Выделение диапазона и использование абсолютных адресов

Выделение ячеек через интервал_2

Движение по ячейкам

Поиск ближайшей пустой ячейки столбца

Поиск максимального значения

Поиск и замена по шаблону

Поиск значения с отображением результата в отдельном окне

Поиск с выделением найденных данных_1

Поиск с выделением найденных данных_2

Поиск по условию в диапазоне

Поиск последней непустой ячейки диапазона

Поиск последней непустой ячейки столбца

Поиск последней непустой ячейки строки

Поиск ячейки синего цвета в диапазоне

Поиск наличия значения в столбце

Поиск совпадений в диапазоне

Поиск ячейки в диапазоне_1

Поиск ячейки в диапазоне_2

Поиск приближенного значения в диапазоне

Поиск начала и окончания диапазона, содержащего данные

Автоматическая замена значений

Быстрое заполнение диапазона (массив)

Заполнение через интервал(массив)

Заполнение указанного диапазона(массив)

Заполнение диапазона(массив)

Расчет суммы первых значений диапазона

Размещение в ячейке электронных часов

«Будильник»

Адрес активной ячейки

Координаты активной ячейки

Формула активной ячейки

Получение из ячейки формулы

Тип данных ячейки

Вывод адреса конца диапазона

Получение информации о выделенном диапазоне

Создание изменяемого списка (таблица)

Умножение выделенного диапазона на 2

Одновременное умножение всех данных диапазона

Деление диапазона на 100

Суммирование данных только видимых ячеек

Сумма ячеек с числовыми значениями

При суммировании — курсор внутри диапазона

Начисление процентов в зависимости от суммы_1

Начисление процентов в зависимости от суммы_2

Начисление процентов в зависимости от суммы_3

Сводный пример расчета комиссионного вознаграждения

Движение по диапазону

Сдвиг от выделенной ячейки

Создание заливки диапазона

Подбор параметра ячейки

Разбиение диапазона

Объединение данных диапазона

Объединение данных диапазона_2

Узнать максимальную колонку или строку.

Ограничение возможных значений диапазона

Тестирование скорости чтения и записи диапазонов

Открыть MsgBox при выборе ячейки

Скрытие строки

Скрытие нескольких строк

Скрытие столбца

Скрытие нескольких столбцов

Скрытие строки по имени ячейки

Скрытие нескольких строк по адресам ячеек

Скрытие столбца по имени ячейки

Скрытие нескольких столбцов по адресам ячеек

Мигание ячейки

ГЛАВА 4. РАБОТА С ПРИМЕЧАНИЯМИ

Вывод на экран всех примечаний рабочего листа

Функция извлечения комментария

Список примечаний защищенных листов

Перечень примечаний в отдельном списке_1

Перечень примечаний в отдельном списке_2

Перечень примечаний в отдельном списке_3

Подсчет количества примечаний_1

Подсчет примечаний_3

Выделение ячеек с примечаниями

Отображение всех примечаний

Изменение цвета примечаний

Добавление примечаний

Добавление примечаний в диапазон по условию

Перенос комментария в ячейку и обратно

Перенос значений из ячейки в комментарий_1

Перенос значений из ячейки в комментарий_2

ГЛАВА 5 . ПОЛЬЗОВАТЕЛЬСКИЕ ВКЛАДКИ НА ЛЕНТЕ

Дополнение панели инструментов

Добавление кнопки на панель инструментов

Панель с одной кнопкой

Панель с двумя кнопками

Создание панели справа

Вызов предварительного просмотра

Создание пользовательского меню (вариант 1)

Создание пользовательского меню (вариант 2)

Создание пользовательского меню (вариант 3)

Создание пользовательского меню (вариант 4)

Создание пользовательского меню (вариант 5)

Создание списка пунктов главного меню Excel

Создание списка пунктов контекстных меню

Отображение панели инструментов при определенном условии

Скрытие и отображение панелей инструментов

Создать подсказку к моим кнопкам

Создание меню на основе данных рабочего листа

Создание контекстного меню

Блокировка контекстного меню

Добавление команды в меню Сервис

Добавление команды в меню Вид

Создание панели со списком

Мультфильм с помощником в главной роли

Дополнение помощника текстом, заголовком, кнопкой и значком

Новые параметры помощника

Использование помощника для выбора цвета заливки

ГЛАВА 6. ДИАЛОГОВЫЕ ОКНА

Функция INPUTBOX (через ввод значения)

Настройка ввода данных в диалоговом окне

Открытие диалогового окна (“Открыть файл”)_1

Вызов броузера из Экселя

Диалоговое окно ввода данных

Значения по умолчанию

ГЛАВА 7.ФОРМАТИРОВАНИЕ ТЕКСТА. ТАБЛИЦЫ. ГРАНИЦЫ И ЗАЛИВКА.

Вывод списка доступных шрифтов

Выбор из текста всех чисел

Прописная буква только в начале текста

Подсчет количества повторов искомого текста

Выделение из текста произвольного элемента

Отображение текста «задом наперед»

Запуск таблицы символов из Excel

ГЛАВА 8 ИНФОРМАЦИЯ О ПОЛЬЗОВАТЕЛЕ, КОМПЬЮТЕРЕ, ПРИНТЕРЕ И Т.Д.

Получить имя пользователя

Вывод разрешения монитора

Получение информации об используемом принтере

Просмотр информации о дисках компьютера

ГЛАВА 9. ДИАГРАММЫ

Построение диаграммы с помощью макроса

Сохранение диаграммы в отдельном файле

Построение и удаление диаграммы нажатием одной кнопки

Применение случайной цветовой палитры

Эффект прозрачности диаграммы

Построение диаграммы на основе данных нескольких рабочих листов

Создание подписей к данным диаграммы

ГЛАВА 10. РАЗНЫЕ ПРОГРАММЫ.

Программа для составления кроссвордов

Игра «Минное поле»

Игра «Угадай животное»

Расчет на основании ячеек определенного цвета

ГЛАВА 11. ДРУГИЕ ФУНКЦИИ И МАКРОСЫ

Вызов функциональных клавиш

Расчет среднего арифметического значения

Перевод чисел в «деньги»

Поиск ближайшего понедельника

Подсчет количества полных лет

Расчет средневзвешенного значения

Преобразование номера месяца в его название

Использование относительных ссылок

Преобразование таблицы Excel в HТМL-формат

Генератор случайных чисел

Случайные числа — на основании диапазона

Применение функции без ввода ее в ячейку

Подсчет именованных объектов

Включение автофильтра с помощью макроса

Создание бегущей строки

Создание бегущей картинки

Вращающиеся автофигуры

Вызов таблицы цветов

Создание калькулятора

Склонение фамилии, имени и отчества

ГЛАВА 12. ДАТА И ВРЕМЯ

Вывод даты и времени_1

Вывод даты и времени_2

Получение системной даты

Извлечение даты и часов

Функция ДатаПолная

ГЛАВА 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:= xlРart, 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

errНandle:

MsgBox Err.Descriрtion, vbExclamation, «Error #» & Err.Number

End Sub

Запуск макроса при открытии книги

Sub Auto_Oрen()

Запуск макроса при вводе в ячейку «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_Selectiоnchange(ByVal Target As Range)

Application.OnKey «{~}», «StartEnter»

End Sub

в модуле книги

Sub StartEnter()

MsgBox («sadfsdfsf»)

End Sub

Добавить в панель свою вкладку «Надстройки» (Формат ячейки)

Код в модуле рабочего листа

Sub Worksheet_Change(ByVal Target As Excel.Range)

Call updаtеToolbar

End Sub

Sub Worksheet_Selectiоnchange(ByVal Target As Excel.Range)

Call updаtеToolbar

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 updаtеToolbar

End Sub

Sub updаtеToolbar()

‘ Обновление панели инструментов (если она создана)

On Error Resume Next

‘ Изменение заголовка кнопки (на название формата выделенной ячейки)

CommandBars(«Числовой формат»).Controls(1).Caption = _

ActiveCell.NumberFormat

End Sub

Sub ChangeNumFormat()

‘ Отображение диалогового окна изменения формата ячейки

Application.Dialogs(xlDialogFormatNumber).Show

Call updаtеToolbar

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.200c», 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 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(«sсriрting.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

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)

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 ‘пишем (с начала)

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

‘ Не забываем закрывать файл

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

Экспорт данных в HТМL

Sub ExportAsHТМLFile()

Dim strStyle As String ‘ Параметры стиля отображения ячейки

Dim strAlign As String ‘ Параметры выравнивания ячейки

Dim strOut As String ‘ Выходная строка с HТМL-кодом

Dim cell As Object ‘ Обрабатываемая ячейка

Dim strCellText As String ‘ Текст обрабатываемой ячейки

Dim lngRow As **** ‘ Номер строки обрабатываемой ячейки

Dim lngLastRow As **** ‘ Номер строки предыдущей ячейки

Dim strTemp As String

Dim strFileName As String ‘ Имя файла для сохранения HТМL-кода

Dim i As ****

‘ Запрос у пользователя имени файла для сохранения

strFileName = Application.GetSaveAsFilename( _

InitialFileName:=»Primer.htm», _

fileFilter:=»HТМL 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

‘ Вставка <tr> для первой строки и </tr> — для последней

strOut = vbTab & «<tr>» & vbCrLf & strOut & vbTab & «</tr>» & vbCrLf

‘ Вставка дескриптора <table>

strOut = «<table border=1 cellpadding=3 cellspacing=1>» _

& vbCrLf & strOut & vbCrLf & «</table>»

‘ Сохранение HТМL-кода в файл

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

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

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

‘получим имя очередного файла

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.Desсriрtion

On Error Resume Next

wd.Quit

Set wd = Nothing

End

End Sub

Копирование данных из закрытой книги

ActiveCell.FormulaR1C1 = «=’D:contactszakaz[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, updаtеLinks:=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

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

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

.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

.TypeText strMessage

.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:windowsinf*.*»)

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 заставляет Exсel игнорировать команду _

отправки книги на печать

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 ‘(еxprеssion.Close(SaveChanges, FileName, RouteWorkbook)

End Sub

Закрытие рабочей книги только при выполнении условия

Sub Workbook_BeforeClose(Cancel As Boolean)

If Range(«A1»).Value <> «Можно закрывать» Then

‘ Условие закрытия не выполнено. Укажем Exсel игнорировать _

команду

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

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.Desсriрtion, 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)

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()

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

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

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)

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

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

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)

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

Else

rgData.Interior.ColorIndex = xlNone

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 ****

‘ Ввод данных в цикле (повторяется до тех пор, пока пользователь _

не введет пустую строку или не нажмет «Отмена» в окне ввода)

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 insеrtCustomText()

‘ Заполнение текущей ячейки

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

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

End Sub

Удаление используемых скрытых строк или строк с нулевой высотой

Sub KillUsedHiddenThinRows()

Dim x

For Each x In ActiveSheet.UsedRange.Rows

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

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

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

‘ получаем адрес вырехней

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

‘ Выделение всех ячеек в объединении

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))

‘ Выделение всех ячеек в объединении

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

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

‘ Поиск завершен. Ячейка не найдена

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

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.insеrt 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

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

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 updаtеTime()

Dim varNextCall As Variant

‘ Записываем в ячейку текущее время

Cells(1, 1).Value = Now

‘ Записываем в varNextCall время, когда вызвать этот макрос _

в следующий раз (через 1 секунду)

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

‘ Уведомляем Excel в необходимости вызова макроса

Application.OnTime varNextCall, «updаtеTime»

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_Selectiоnchange(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

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

End Sub

Возведение каждой ячейки диапазона в квадрат

Суммирование данных только видимых ячеек

Function СуммаВид(Диапазон) As Double

‘ Просмотр всех ячеек заданного диапазона

For Each Ячейка In Диапазон

‘ Анализ только видимых ячеек

If Not Ячейка.EntireRow.Hidden And Not _

Ячейка.EntireColumn.Hidden Then

‘ При расчете учитываются только ячейки _

с численными значениями

If IsNumeric(Ячейка) = True Then

СуммаВид = СуммаВид + Ячейка

End If

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

MsgBox «Сумма ячеек: » & intSum

End Sub

При суммировании — курсор внутри диапазона

Function Сумма(Диапазон, АдресЯчейки) As Double

‘ Просмотр всех ячеек диапазона

For Each Ячейка In Диапазон

‘ Проверка, чтобы в суммировании не участвовала _

ячейка с формулой

If АдресЯчейки.Address <> Ячейка.Address Then

‘ В суммировании участвуют только ячейки _

с численными значениями

If IsNumeric(Ячейка) = True Then

Сумма = Сумма + Ячейка

End If

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

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 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 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

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_Selectiоnchange(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

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

‘ Добавление текста примечания в выходную строку

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

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

‘ Вывод текста в столбец «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

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)

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

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

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

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

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 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 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 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

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_Selectiоnchange(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 = «Buttоnclick» & i

.FaceId = i + 37

End With

Next i

cbrBar.Name = «AutoSense»

End Sub

Sub Buttоnclick3()

‘ Перемещение вниз

On Error Resume Next

ActiveCell.Offset(1, 0).Activate

End Sub

Sub Buttоnclick1()

‘ Перемещение вверх

On Error Resume Next

ActiveCell.Offset(-1, 0).Activate

End Sub

Sub Buttоnclick2()

‘ Перемещение вправо

On Error Resume Next

ActiveCell.Offset(0, 1).Activate

End Sub

Sub Buttоnclick4()

‘ Перемещение влево

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

‘ Включение обновления экрана

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

‘ Кнопка «Границы»

With .Add(msoControlButton)

.Caption = «&Границы…»

.OnAction = «ShowFormatBorder»

.FaceId = 149

.BeginGroup = True

End With

‘ Кнопка «Узор»

With .Add(msoControlButton)

.Caption = «&Узор…»

.OnAction = «ShowFormatPatterns»

.FaceId = 1550

End With

‘ Кнопка «Защита»

With .Add(msoControlButton)

.Caption = «&Защита…»

.OnAction = «ShowFormatProtection»

.FaceId = 2654

End With

End Sub

Блокировка контекстного меню

Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)

Static intCount As Integer ‘ Счетчик нажатий кнопки мыши

Dim x As Integer, y As Integer

‘ Блокировать обработку щелчка правой кнопкой мыши

Cancel = True

‘ Отображение текстового поля с количеством щелчков правой _

кнопкой мыши

x = Target.Left

y = Target.Top

intCount = intCount + 1

ActiveSheet.Shapes.AddTextbox(msoTextOrientationHorizontal, _

x, y, 35, 20).TextFrame.Characters.Text = intCount

End Sub

Добавление команды в меню Сервис

Sub AddMenuItem()

Dim cbrpMenu As CommandBarPopup

‘ Удаление аналогичной команды (при ее наличии)

Call DeleteMenuItem

‘ Получение доступа к меню «Сервис»

Set cbrpMenu = CommandBars(1).FindControl(ID:=30007)

If cbrpMenu Is Nothing Then

‘ Не удалось получить доступ

MsgBox «Невозможно добавить элемент.»

Exit Sub

Else

‘ Добавление новой команды в меню

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

‘ Название команды

.Caption = «Очистить в&се, кроме формул»

‘ Значок

.FaceId = 348

‘ Сочетание клавиш (только надпись на кнопке)

.ShortcutText = «Ctrl+Shift+C»

‘ Сопоставленный макрос

.OnAction = «ExecuteCommand»

‘ Добавление разделителя перед командой

.BeginGroup = True

End With

End If

‘ Сопоставление с макросом сочетания клавиш Ctrl+Shift+C

Application.MacroOptions _

Macro:=»ExecuteCommand», _

HasShortcutKey:=True, _

ShortcutKey:=»C»

End Sub

Sub ExecuteCommand()

‘ Очистка содержимого всех ячеек (кроме формул)

On Error Resume Next

Cells.SpecialCells(xlCellTypeConstants, 23).ClearContents

End Sub

Sub DeleteMenuItem()

‘ Удаление команды из меню

On Error Resume Next

CommandBars(1).FindControl(ID:=30007). _

Controls(«Очистить в&се, кроме формул»).Delete

End Sub

Добавление команды в меню Вид

Листинг 3.110. Код в стандартном модуле

Dim AppObject As New Class1

Sub AddCommand()

Dim cbrpBar As CommandBarPopup

‘ Удаление аналогичной команды (при ее наличии)

Call DeleteCommand

‘ Получение доступа к меню «Вид»

Set cbrpBar = CommandBars(1).FindControl(ID:=30004)

If cbrpBar Is Nothing Then

‘ Не удалось получить доступ к меню

MsgBox «Невозможно добавить элемент меню.»

Exit Sub

Else

‘ Добавление команды

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

.Caption = «&Линии сетки»

.OnAction = «GhangeGridlinesState»

End With

End If

‘ Даем объекту AppObject обрабатывать события

Set AppObject.AppEvents = Application

End Sub

Sub DeleteCommand()

‘ Удаление каманды из меню (если она там есть)

On Error Resume Next

CommandBars(1).FindControl(ID:=30004). _

Controls(«&Линии сетки»).Delete

End Sub

Sub GhangeGridlinesState()

‘ Изменение состояния отображения линий сетки _

на противоположное (если нет — покажем, если есть — скроем)

If TypeName(ActiveSheet) = «Worksheet» Then

ActiveWindow.DisplayGridlines = _

Not ActiveWindow.DisplayGridlines

‘ Установка или снятие флажка в меню

Call CheckGridlines

End If

End Sub

Sub CheckGridlines()

Dim button As CommandBarButton

On Error Resume Next

‘ Поиск команды «Линии сетки» в меню «Вид»

Set button = CommandBars(1).FindControl(ID:=30004). _

Controls(«&Линии сетки»)

‘ Изменение состояния флажка на противоположное

If ActiveWindow.DisplayGridlines Then

‘ Установка

button.State = msoButtonDown

Else

‘ Снятие

button.State = msoButtonUp

End If

End Sub

Создание панели со списком

Sub DeleteCustomContextMenu()

‘ Удаление меню

On Error Resume Next

CommandBars(«MyContextMenu»).Delete

End Sub

Sub ShowFormatNumber()

‘ Число

Application.Dialogs(xlDialogFormatNumber).Show

End Sub

Sub ShowFormatAlignment()

‘ Выравнивание

Application.Dialogs(xlDialogAlignment).Show

End Sub

Sub ShowFormatFont()

‘ Шрифт

Application.Dialogs(xlDialogFormatFont).Show

End Sub

Sub ShowFormatBorder()

‘ Граница

Application.Dialogs(xlDialogBorder).Show

End Sub

Sub ShowFormatPatterns()

‘ Вид (Узор)

Application.Dialogs(xlDialogPatterns).Show

End Sub

Sub ShowFormatProtection()

‘ Защита

Application.Dialogs(xlDialogCellProtection).Show

End Sub

Sub CreatePanel()

Dim i As Integer

On Error Resume Next

‘ Удаление одноименной панели (если есть)

CommandBars(«Список месяцев»).Delete

On Error GoTo 0

‘ Создание панели «Список месяцев»

With CommandBars.Add

.Name = «Список месяцев»

‘ Создание списка месяцев

With .Controls.Add(Type:=msoControlDropdown)

‘ Настройка (имя, макрос, стиль)

.Caption = «DateDD»

.OnAction = «SetMonth»

.Style = msoButtonAutomatic

‘ Добавление в список названий месяцев

For i = 1 To 12

.AddItem Format(DateSerial(1, i, 1), «mmmm»)

Next i

‘ Выделение первого месяца

.ListIndex = 1

End With

‘ Показываем созданную панель

.Visible = True

End With

End Sub

Sub SetMonth()

‘ Перенос названия выделенного месяца в ячейку

On Error Resume Next

With CommandBars(«Список месяцев»).Controls(«DateDD»)

ActiveCell.Value = .List(.ListIndex)

End With

End Sub

Мультфильм с помощником в главной роли

Листинг 4.1. «Танцующий» помощник

Sub RunAssistantDance()

Static intAction As Integer

‘ Заставляем помощника выполнять действие (всего 16)

DoAssistantAction intAction

intAction = intAction + 1

If intAction < 16 Then

‘ Следующее действие через 3 секунды

Application.OnTime Time + TimeValue(«00:00:3»), _

«RunAssistantDance»

End If

End Sub

Sub DoAssistantAction(intAction As Integer)

Dim astAssistant As Assistant

Set astAssistant = Application.Assistant

‘ Помещаем помощника в центр активного окна

astAssistant.Top = Application.ActiveWindow.Top _

+ Application.ActiveWindow.Height / 2

astAssistant.Left = Application.ActiveWindow.Left _

+ Application.ActiveWindow.Width / 2

‘ Показываем помощника

astAssistant.On = True

astAssistant.Visible = True

‘ Показываем заданное параметром intAction действие

Select Case intAction

Case 0

astAssistant.Animation = msoAnimationAppear

Case 1

astAssistant.Animation = msoAnimationCheckingSomething

Case 2

astAssistant.Animation = msoAnimationBeginSpeaking

Case 3

astAssistant.Animation = msoAnimationCharacterSuccessMajor

Case 4

astAssistant.Animation = msoAnimationEmptyTrash

Case 5

astAssistant.Animation = msoAnimationGestureDown

Case 5

astAssistant.Animation = msoAnimationGestureLeft

Case 6

astAssistant.Animation = msoAnimationGestureRight

Case 7

astAssistant.Animation = msoAnimationGestureUp

Case 8

astAssistant.Animation = msoAnimationGetArtsy

Case 9

astAssistant.Animation = msoAnimationGetAttentionMajor

Case 10

astAssistant.Animation = msoAnimationGetAttentionMinor

Case 11

astAssistant.Animation = msoAnimationGetTechy

Case 12

astAssistant.Animation = msoAnimationGetWizardy

Case 13

astAssistant.Animation = msoAnimationGoodbye

Case 14

astAssistant.Animation = msoAnimationGreeting

Case 15

astAssistant.Animation = msoAnimationDisappear

End Select

End Sub

Дополнение помощника текстом, заголовком, кнопкой и значком

Листинг 4.2. Настройка помощника

Sub AssistantMessage()

Dim strTitle As String ‘ Заголовок сообщения

Dim strMessage As String ‘ Текст сообщения

‘ Содержимое заголовка и текста в окне помощника

strTitle = «Спрашивайте — ответим»

strMessage = «{cf 249}{ul 1} Руки мыли{ul 0}?» _

& vbCr & «{cf 6} Не забыть обновить антивирус!»

‘ Настраиваем помощника

With Application.Assistant

‘ Включаем и показываем помощника

.On = True

.Visible = True

‘ Создаем окно сообщения

With .NewBalloon

.BalloonType = msoBalloonTypeButtons

‘ Кнопка «ОК» в окне помощника

.button = msoButtonSetOK

‘ Значок в окне помощника

.Icon = msoIconAlert

‘ Заголовок в окне помощника

.Heading = strTitle

‘ Текст в окне помощника

.Text = strMessage

‘ Отображение окна

.Show

End With

End Sub

Новые параметры помощника

Листинг 4.3. Новые параметры помощника

Sub AssistantCheckboxes()

Dim i As Integer

Dim strMessage As String

With Assistant

‘ Включение и отображение помощника

.On = True

.Visible = True

‘ Создание окна сообщения

With .NewBalloon

‘ Настройка окна…

‘ Тип окна

.BalloonType = msoBalloonTypeButtons

‘ Заголовок

.Heading = «Выберите страну»

‘ Добавление флажков

.CheckBoxes(1).Text = «Россия»

.CheckBoxes(2).Text = «США»

.CheckBoxes(3).Text = «Южная Африка»

.button = msoButtonSetOkCancel

‘ Отображение окна

If .Show = msoBalloonButtonOK Then

‘ Вывод информационного окна в зависимости _

от установленных флажков

For i = 1 To 3

If .CheckBoxes(i).Checked Then

strMessage = strMessage & _

.CheckBoxes(i).Text & vbCr

End If

‘ Отображение окна сообщения (имеется в виду _

стандартное окно)

If Len(strMessage) = 0 Then

MsgBox «No choice.»

Else

MsgBox strMessage

End If

End With

End Sub

Использование помощника для выбора цвета заливки

Листинг 4.4. Выбор цвета заливки рабочего листа

Sub AssistantChooseColor()

Dim intChoise As Integer

With Assistant

‘ Включение и отображение помощника

.On = True

.Visible = True

With .NewBalloon

‘ Настройка окна…

‘ Тип

.BalloonType = msoBalloonTypeButtons

‘ Заголовок

.Heading = «Какой нужен цвет?»

‘ Первый цвет

.Labels(1).Text = «Красный»

‘ Второй цвет

.Labels(2).Text = «Желтый»

‘ Третий цвет

.Labels(3).Text = «Зеленый»

‘ Тип кнопок

.button = msoButtonSetNone

‘ Оображение окна

intChoise = .Show

‘ Информационное сообщение о выбранном цвете

MsgBox «Выбран: » & .Labels(intChoise).Text

End With

‘ Настройка цветов ячеек (присвоение выбранного цвета)

Select Case intChoise

Case 1

‘ Красный цвет

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

Case 2

‘ Желтый цвет

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

Case 3

‘ Зеленый цвет

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

End Select

End Sub

ГЛАВА 6. ДИАЛОГОВЫЕ ОКНА

Функция INPUTBOX (через ввод значения)

Public Sub ИнпутБокс()

Dim текст As Variant

MsgBox «Если в InputBox нажать Отмена, в ячейке будут удалены все данные»

текст = InputBox(«Введите текст», «Окно ввода текста», «222»)

MsgBox текст

If текст <> «» Then

Range(«H7») = текст

MsgBox «Как сделать так, чтобы при выборе пользователем в InputBox — Отмена он закрывался и прекращалось выполнение процедуры?»

Else

Exit Sub

End If

End Sub

Вызов предварительного просмотра

Sub Test()

With Application.Workbooks.Item(«Test.xls»)

Sheets(«Test»).PrintPreview

End With

End Sub

Настройка ввода данных в диалоговом окне

Sub DialogInputData()

Dim intMin As Integer, intMax As Integer ‘ Диапазон значений

Dim strInput As String ‘ Введенная пользователем строка

Dim strMessage As String

Dim intValue As Integer

intMin = 1 ‘ Минимальное значение

intMax = 50 ‘ Максимальное значение

strMessage = «Введите значение от » & intMin & » до » & intMax

‘ Ввод значения (цикл завершается, когда пользователь вводит _

значение из заданного диапазона или отменяет ввод)

strInput = InputBox(strMessage)

If strInput = «» Then Exit Sub ‘ Отмена ввода

‘ Проверка, содержит ли введенная пользователем строка число

If IsNumeric(strInput) Then

intValue = CInt(strInput)

‘ Проверка, удовлетворяет ли значение диапазону

If intValue >= intMin And intValue <= intMax Then

‘ Все условия выполнены

Exit Do

End If

‘ Формирование сообщения с текстом ошибки

strMessage = «Вы ввели некорректное значение.» & vbNewLine & _

«Введите число от » & intMin & » до » & intMax

Loop

‘ Внесение данных в ячейку

ActiveSheet.Range(«A1»).Value = strInput

End Sub

Открытие диалогового окна (“Открыть файл”)_1

Sub Test()

Application.Dialogs(xlDialogOpen).Show «*.dbf»

End Sub

Открытие диалогового окна (“Открыть файл”)_2

fileToOpen = Application.GetOpenFilename(«Text Files (*.txt), *.txt»)

If fileToOpen <> False Then

MsgBox «Open » & fileToOpen

End If

Открытие диалогового окна (“Печать”)

Application.Dialogs(xlDialogPrint).Show

Другие диалоговые окна

xlDialogClear — очистка ячейки или диапазона

xlDialogDisplay — параметры отображения ячеек

xlDialogFileDelete — удаление файла

xlDialogSaveWorkbook — сохранить книгу

xlDialogSearch — поиск в документе

xlDialogWorkbookName — переименование листа

Вызов броузера из Экселя

Надо создать кнопку которой добавить код:

Sub Button1_Click()

Call ShellExecute(GetDesktopWindow, «Open», «www.armentel.com/avb», «», «c:», SW_SHOWNORMAL)

End Sub

И функция:

Private Declare Function ShellExecute& Lib «shell32.dll» Alias «ShellExecuteA» (ByVal hwnd As ****, ByVal _

lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, _

ByVal nShowCmd As ****)

Private Declare Function GetDesktopWindow Lib «user32» () As ****

Const SW_SHOWNORMAL = 1

Диалоговое окно ввода данных

Sub InputDialog()

Dim strInput As String

‘ Вызов стандартного диалогового окна ввода данных

strInput = InputBox(«Введите данные», «Ввод данных»)

End Sub

Диалоговое окно настройки шрифта

Sub ShowFontDialog()

‘ Вызов стандартного окна настройки шрифта текущей ячейки

Application.Dialogs(xlDialogActiveCellFont).Show

End Sub

Значения по умолчанию

Sub NewInputDialog()

Dim strInput As String

‘ Вызов стандартного диалогового окна ввода со значением _

по умолчанию

strInput = InputBox(«Введите данные», «Ввод данных», _

«Значение по умолчанию», 200, 200)

End Sub

ГЛАВА 7.ФОРМАТИРОВАНИЕ ТЕКСТА. ТАБЛИЦЫ. ГРАНИЦЫ И ЗАЛИВКА.

Вывод списка доступных шрифтов

Листинг 3.104. Список шрифтов

Sub ListOfFonts()

Dim cbrcFonts As CommandBarControl

Dim cbrBar As CommandBar

Dim i As Integer

‘ Получение доступа к списку шрифтов (элемент управления в виде _

раскрывающегося списка на панели инструментов «Форматирование»)

Set cbrcFonts = Application.CommandBars(«Formatting»). _

FindControl(ID:=1728)

If cbrcFonts Is Nothing Then

‘ Панель «Форматирование» не открыта — откроем ее

Set cbrBar = Application.CommandBars.Add

Set cbrcFonts = cbrBar.Controls.Add(ID:=1728)

End If

‘ Подготовка к выводу шрифтов (очистка ячеек)

Range(«A:A»).ClearContents

‘ Вывод списка шрифтов в столбец «A» текущего листа

For i = 0 To cbrcFonts.ListCount — 1

Cells(i + 1, 1) = cbrcFonts.List(i + 1)

Next i

‘ Закрытие панели инструментов «Форматирование», если мы были _

вынуждены ее открывать

On Error Resume Next

cbrBar.Delete

End Sub

Выбор из текста всех чисел

Листинг 2.48. Функция ExtractNumeric

Function ExtractNumeric(iCell)

‘ Анализируется каждый символ входной строки iCell

For iCount = 1 To Len(iCell)

‘ Проверка, является ли анализируемый символ числом

If IsNumeric(Mid(iCell, iCount, 1)) = True Then

‘ Число добавляется в выходную строку

ExtractNumeric = ExtractNumeric & Mid(iCell, iCount, 1)

End If

End Function

Прописная буква только в начале текста

Листинг 2.49. Функция ПрописнНач

Function ПрописнНач(Текст)

‘ Пустой текст функция не обрабатывает

If Текст = «» Then ПрописнНач = «<>»: Exit Function

‘ Выделение первого символа и перевод его в верхний регистр

ПервыйСимвол = UCase(Left(Текст, 1))

‘ Выделение остальной части строки и перевод _

ее в нижний регистр

Обрубок = LCase(Mid(Текст, 2))

‘ Соединение частей строки и возврат значения

ПрописнНач = ПервыйСимвол & Обрубок

End Function

Подсчет количества повторов искомого текста

Листинг 2.51. Функция CoincideCount

Function CoincideCount(Text, Search)

‘ Проверка правильности входных данных _

(аргумента Search)

If IsArray(Search) = True Then Exit Function

If IsError(Search) = True Then Exit Function

If IsEmpty(Search) = True Then Exit Function

‘ Просмотр заданного в параметре Text диапазона

For Each iCell In Text

‘ Анализируются только ячейки, содержащие _

корректные значения

If Not IsError(iCell) Then

‘ iText — строка для просмотра (в нижнем регистре)

iText = LCase(iCell)

‘ iSearch — искомое значение (в нижнем регистре)

iSearch = LCase(Search)

‘ Длина искомой строки

iLen = Len(Search)

‘ Первый поиск строки iSearch в строке iText _

(этот и последующий поиски производятся без _

учета регистра символов)

iNumber = InStr(iText, iSearch)

While iNumber > 0

‘ Поиск следующего вхождения строки

iNumber = InStr(iNumber + iLen, iText, iSearch)

‘ Подсчет количества вхождений

CoincideCount = CoincideCount + vbNull

Wend

End If

End Function

Выделение из текста произвольного элемента

Листинг 2.76. Выделение элемента текста

Function dhGetTextItem(ByVal strTextIn As String, intItem As _

Integer, strSeparator As String) As String

Dim intStart As Integer ‘ Позиция начала текущего элемента

Dim intEnd As Integer ‘ Позиция конца текущего элемента

Dim i As Integer ‘ Номер текущего элемента

‘ Проверка корректности номера элемента

If intItem < 1 Then Exit Function

‘ Убираются лишние пробелы, если разделитель — пробел

If strSeparator = » » Then strTextIn = Application.Trim(strTextIn)

‘ Разделитель добавляется в конец строки

If Right(strTextIn, Len(strTextIn)) <> strSeparator Then _

strTextIn = strTextIn & strSeparator

‘ Поиск всех элементов в строке до нужного

For i = 1 To intItem

‘ Начало элемента (перемещение вперед по строке)

intStart = intEnd + 1

‘ Конец элемента

intEnd = InStr(intStart, strTextIn, strSeparator)

If (intEnd = 0) Then

‘ Дошли до конца строки, но элемент не нашли

Exit Function

End If

Next i

‘ Выделение текста из входной строки

dhGetTextItem = Mid(strTextIn, intStart, intEnd — intStart)

End Function

Отображение текста «задом наперед»

Листинг 2.71. Преобразование текста в обратном порядке

Function dhReverseText(strText As String) As String

Dim i As Integer

‘ Переписываем символы из входной строки в выходную _

в обратном порядке

For i = Len(strText) To 1 Step -1

dhReverseText = dhReverseText & Mid(strText, i, 1)

Next i

End Function

Sub ReverseText()

Dim strText As String

‘ Ввод строки посредством стандартного окна ввода

strText = InputBox(«Введите текст:»)

‘ Реверсия строки и вывод результата

MsgBox dhReverseText(strText), , strText

End Sub

Англоязычный текст — заглавными буквами

Листинг 2.70. Английский текст — в верхнем регистре

Function dhFormatEnglish(strText As String) As String

Dim i As Integer

Dim strCurChar As String * 1

‘ Анализируется каждый символ строки strText. Каждый символ _

латинского алфавита преобразуется в верхний регистр

For i = 1 To Len(strText)

strCurChar = Mid(strText, i, 1)

‘ Код латинских строчных символов лежит в пределах _

от 97 до 122

If Asc(strCurChar) >= 97 And Asc(strCurChar) <= 122 Then

‘ Переводим символ в верхний регистр

dhFormatEnglish = dhFormatEnglish & UCase(strCurChar)

Else

‘ Просто добавляем символ в выходную строку

dhFormatEnglish = dhFormatEnglish & strCurChar

End If

Next i

End Function

Запуск таблицы символов из Excel

Листинг 3.106. Вызов таблицы символов

Sub ShowSymbolTable()

On Error Resume Next

‘ Запуск Charmap.exe — таблицы символов

Shell «Charmap.exe», vbNormalFocus

If Err <> 0 Then

MsgBox «Невозможно запустить таблицу символов.», vbCritical

End If

End Sub

Листинг 3.107. Таблица символов

‘ Декларация API-функций:

‘ для открытия процесса

Declare Function OpenProcess Lib «kernel32» _

(ByVal dwDesiredAccess As ****, ByVal bInheritHandle As ****, _

ByVal dwProcessId As ****) As ****

‘ для получения кода завершения процесса

Declare Function GetExitCodeProcess Lib «kernel32» _

(ByVal hProcess As ****, lpExitCode As ****) As ****

‘ для закрытия процесса

Declare Function CloseHandle Lib «kernel32» _

(hProcess) As ****

Sub ShowSymbolTable1()

Dim lProcessID As ****

Dim hProcess As ****

Dim lExitCode As ****

On Error Resume Next

‘ Запуск таблицы символов (Charman.exe). Функция возвращает _

идентификатор созданного процесса

lProcessID = Shell(«Charmap.exe», 1)

If Err <> 0 Then

MsgBox «Нельзя запустить Charman.exe», vbCritical, «Ошибка»

Exit Sub

End If

‘ Открытие процесса по идентификатору (lProcessID). Функция _

возвращает дескриптор процесса (handle)

hProcess = OpenProcess(&H400, False, lProcessID)

‘ Ждем, пока процесс завершится, для этого периодически _

получаем код завершения процесса (пока Charman.exe исполняется, _

функция GetExitCodeProcess возвращает &H103)

GetExitCodeProcess hProcess, lExitCode

DoEvents

Loop While lExitCode = &H103

‘ Закрытие процесса

CloseHandle (hProcess)

‘ Вывод на экран информационного сообщения

MsgBox «Charmap.exe завершает свою работу»

End Sub

Листинг 3.64. Формат «два знака после запятой»

Sub ChangeNumberFormat()

Selection.NumberFormat = «0.00»

End Sub

Листинг 3.65. Использование разделителя по разрядам

Sub ThreeNullSepatator()

Selection.NumberFormat = «#,##»

End Sub

Листинг 3.66. Изменение формата

Sub ChangeNumerFormatEx()

Selection.NumberFormat = «#,##0.00»

End Sub

Листинг 3.67. Помещение последнего символа над строкой

Sub LastCharUp()

‘ Изменение расположения последнего символа ячейки

With ActiveCell.Characters(Start:=Len(Selection), Length:=1).Font

.Supersсriрt = True

End With

End Sub

Листинг 3.68. Нестандартная рамка

Sub ChangeSelGrid()

‘ Оформление границ выделения

‘ Левая граница

With Selection.Borders(xlEdgeLeft)

.LineStyle = xlContinuous

.Weight = xlThin

.ColorIndex = xlAutomatic

End With

‘ Правая граница

With Selection.Borders(xlEdgeRight)

.LineStyle = xlContinuous

.Weight = xlThin

.ColorIndex = xlAutomatic

End With

‘ Верхняя граница

With Selection.Borders(xlEdgeTop)

.LineStyle = xlContinuous

.Weight = xlThin

.ColorIndex = xlAutomatic

End With

‘ Нижняя граница

With Selection.Borders(xlEdgeBottom)

.LineStyle = xlContinuous

.Weight = xlThin

.ColorIndex = xlAutomatic

End With

‘ Изменение сетки внутри выделения

‘ Вертикальные линии сетки

With Selection.Borders(xlInsideVertical)

.LineStyle = xlContinuous

.Weight = xlHairline

.ColorIndex = xlAutomatic

End With

‘ Горизонтальные линии сетки

With Selection.Borders(xlInsideHorizontal)

.LineStyle = xlContinuous

.Weight = xlHairline

.ColorIndex = xlAutomatic

End With

End Sub

ГЛАВА 8 ИНФОРМАЦИЯ О ПОЛЬЗОВАТЕЛЕ, КОМПЬЮТЕРЕ, ПРИНТЕРЕ И Т.Д.

Получить имя пользователя

Логин юзера получить просто:

Dim UserName As String

UserName = CreateObject(«Wsсriрt.Network»).UserName

А как отслеживать — вариатнов много.

Я, например, просто не выполняю макрос, если логин не тот:

If ThisWorkbook.Sheets(«Rules»).Range(«Admin»).Find(CreateObject(«Wsсriрt.Network»).UserName, _

LookAt:=xlWhole, LookIn:=xlValues) Is Nothing Then Exit Sub

MsgBox «Имя пользователя : » & CreateObject(«Wsсriрt.Network»).UserNam

CreateObject(«Wsсriрt.Network»).UserName вместо Application.UserName

Вывод разрешения монитора

Листинг 3.73. Разрешение монитора

‘Объявление API-функции

Declare Function GetSystemMetrics Lib «user32» _

(ByVal nIndex As ****) As ****

‘ Константы, которые передаются в функцию для определения _

горизонтального и вертикального размеров изображения

Const SM_CXSCREEN = 0

Const SM_CYSCREEN = 1

Sub GetMonitorResolution()

Dim lngHorzRes As ****

Dim lngVertRes As ****

‘ Получение ширины и высоты изображения на мониторе

lngHorzRes = GetSystemMetrics(SM_CXSCREEN)

lngVertRes = GetSystemMetrics(SM_CYSCREEN)

‘ Отображение сообщения

MsgBox «Текущее разрешение: » & lngHorzRes & «x» & lngVertRes

End Sub

Получение информации об используемом принтере

Информация о принтере

‘ Объявление API-функции

Declare Function GetProfileStringA Lib «kernel32» _

(ByVal lpAppName As String, ByVal lpKeyName As String, _

ByVal lpDefault As String, ByVal lpReturnedString As _

String, ByVal nSize As ****) As ****

Sub Принтер()

Dim strFullInfo As String * 255 ‘ Буфер для API-функции

Dim strInfo As String ‘ Строка с полной информацией

Dim strPrinter As String ‘ Название принтера

Dim strDriver As String ‘ Драйвер принтера

Dim strPort As String ‘ Порт принтера

Dim strMessage As String

Dim intPrinterEndPos As Integer

Dim intDriverEndPos As Integer

‘ Заполнение буфера пробелами

strFullInfo = Space(255)

‘ Получение полной информации о принтере

Call GetProfileStringA(«Windows», «Device», «», strFullInfo, 254)

‘ Удаление лишних символов из конца возвращенной строки

‘ Строка strInfo имеет формат <имя_принтера>,<драйвер>,<порт>:

strInfo = Trim(strFullInfo)

‘ Поиск запятых в строке (окончаний названий принтера и драйвера)

intPrinterEndPos = Application.Find(«,», strInfo, 1)

intDriverEndPos = Application.Find(«,», strInfo, intPrinterEndPos + 1)

‘ Определение названия принтера

strPrinter = Left(strInfo, intPrinterEndPos — 1)

‘ Определение драйвера

strDriver = Mid(strInfo, intPrinterEndPos + 1, intDriverEndPos _

— intPrinterEndPos — 1)

‘ Определение порта (его название заканчивается символом «:»)

strPort = Mid(strInfo, intDriverEndPos + 1, InStr(1, strInfo, «:») _

— intDriverEndPos — 1)

‘ Формирование информационного сообщения

strMessage = «Принтер:» & Chr(9) & strPrinter & Chr(13)

strMessage = strMessage & «Драйвер:» & strDriver & Chr(13)

strMessage = strMessage & «strPort:» & Chr(9) & strPort

‘ Вывод информационного сообщения

MsgBox strMessage, vbInformation, «Сведения о принтере по умолчанию»

End Sub

Просмотр информации о дисках компьютера

Sub DrivesInfo()

Dim objFileSysObject As Object ‘ Объект для работы _

с файловой системой

Dim objDrive As Object ‘ Анализируемый диск

Dim intRow As Integer ‘ Заполняемая строка листа

‘ Создание объекта для работы с файловой системой

Set objFileSysObject = CreateObject(«sсriрting.FileSystemObject»)

‘ Очистка листа

Cells.Clear

‘ Запись с первой строки

intRow = 1

‘ Запись на лист информации о дисках компьютера

On Error Resume Next

For Each objDrive In objFileSysObject.Drives

‘ Буква диска

Cells(intRow, 1) = objDrive.DriveLetter

‘ Готовность

Cells(intRow, 2) = objDrive.IsReady

‘ Тип диска

Select Case objDrive.DriveType

Case 0

Cells(intRow, 3) = «Неизвестно»

Case 1

Cells(intRow, 3) = «Съемный»

Case 2

Cells(intRow, 3) = «Жесткий»

Case 3

Cells(intRow, 3) = «Сетевой»

Case 4

Cells(intRow, 3) = «CD-ROM»

Case 5

Cells(intRow, 3) = «RAM»

End Select

‘ Метка диска

Cells(intRow, 4) = objDrive.VolumeName

‘ Общий размер

Cells(intRow, 5) = objDrive.TotalSize

‘ Свободное место

Cells(intRow, 6) = objDrive.AvailableSpace

intRow = intRow + 1

End Sub

ГЛАВА 9. ДИАГРАММЫ

Построение диаграммы с помощью макроса

Листинг 5.1. Макрос построения диаграммы

Sub CreateChart()

‘ Создание и настройка диаграммы

With Charts.Add

‘ Данные из первого листа

.SetSourceData Source:=Worksheets(1).Range(«A1:E4»)

‘ Заголовок

.HasTitle = True

.ChartTitle.Text = «Выручка по магазинам»

‘ Активизируем диаграмму

.Activate

End With

End Sub

Листинг 5.2. Построение внедренной диаграммы

Sub CreateеmbеddedChart()

‘ Создание и настройка внедренной диаграммы

With Worksheets(1).ChartObjects.Add(100, 60, 250, 200)

‘ Объемная диаграмма

.Chart.ChartType = xl3DArea

‘ Источник данных

.Chart.SetSourceData Source:=Worksheets(1).Range(«A1:E4»)

End With

End Sub

Листинг 5.3. Создание диаграммы на основе выделенных данных

Sub CreateCharOnSelection()

‘ Создание диаграммы (с заданием положения на листе)

With ActiveSheet.ChartObjects.Add( _

Selection.Left + Selection.Width, _

Selection.Top + Selection.Height, 300, 200).Chart

‘ Тип диаграммы

.ChartType = xlColumnClustered

‘ Источник данных — выделение

.SetSourceData Source:=Selection, PlotBy:=xlColumns

‘ Без легенды

.HasLegend = False

‘ Без заголовка

.HasTitle = True

.ChartTitle.Characters.Text = «Выручка за период»

‘ Выделение диаграммы

.Parent.Select

End With

End Sub

Сохранение диаграммы в отдельном файле

Листинг 5.4. Сохранение диаграммы

Sub SaveChart()

‘ Сохранение выделенной диаграммы в файл

If ActiveChart Is Nothing Then

‘ Нет выделенных диаграмм

MsgBox «Выделите диаграмму»

Else

‘ Сохранение…

ActiveChart.Export ActiveWorkbook.path & «Диаграмма.gif», «GIF»

End If

End Sub

Листинг 5.5. Сохранение диаграммы под указанным именем

Sub InteractiveSaveChart()

Dim strFileName As String ‘ Имя файла для сохранения

‘ Проверка, выделена ли диаграмма

If ActiveChart Is Nothing Then

‘ Нет выделенных диаграмм

MsgBox «Выделите диаграмму»

Else

‘ Выбор файла для сохранения

strFileName = Application.GetSaveAsFilename( _

ActiveChart.Name & «.gif», «Файлы GIF (*.gif), *.gif», 1, _

«Сохранить диаграмму в формате GIF»)

‘ Проверка, выбран ли файл

If strFileName <> «» Then

‘ Сохранение выделенной диаграммы в файл

ActiveChart.Export strFileName, «GIF»

End If

End Sub

Построение и удаление диаграммы нажатием одной кнопки

Листинг 5.6. Быстрое построение и удаление диаграммы

Sub CreateChart()

‘ Создание диаграммы

Charts.Add

‘ Параметры диаграммы

‘ Тип диаграммы

ActiveChart.ChartType = xlLineMarkers

‘ Заголовок

ActiveChart.SetSourceData Range(«B1:E2»), xlRows

ActiveChart.Location xlLocationAsObject, Name

‘ Остальные параметры

With ActiveChart

‘ Заголовок

.HasTitle = True

.ChartTitle.Characters.Text = Name

‘ Заголовок оси категорий

.Axes(xlCategory, xlPrimary).HasTitle = True

.Axes(xlCategory, xlPrimary).AxisTitle.Characters.Text _

= Sheets(Name).Range(«A1»).Value

‘ Заголовок оси значений

.Axes(xlValue, xlPrimary).HasTitle = True

.Axes(xlValue, xlPrimary).AxisTitle.Characters.Text _

= Sheets(Name).Range(«A2»).Value

‘ Отображение легенды

.HasLegend = False

.HasDataTable = True

.DataTable.ShowLegendKey = True

‘ Настройка отображения сетки

With .Axes(xlCategory)

.HasMajorGridlines = True

.HasMinorGridlines = False

End With

With .Axes(xlValue)

.HasMajorGridlines = True

.HasMinorGridlines = False

End With

End Sub

Sub DeleteChart()

‘ Удаление диаграммы

ActiveSheet.ChartObjects.Delete

End Sub

Вывод списка диаграмм в отдельном окне

Листинг 5.7. Внедренные диаграммы

Sub ShowSheetCharts()

Dim strMessage As String

Dim i As Integer

‘ Формирование списка диаграмм

For i = 1 To ActiveSheet.ChartObjects.Count

strMessage = strMessage & ActiveSheet.ChartObjects(i).Name _

& vbNewLine

Next i

‘ Отображение списка

MsgBox strMessage

End Sub

Листинг 5.8. Перечень рабочих листов, содержащих обычные диаграммы

Sub ShowBookCharts()

Dim crt As chart

Dim strMessage As String

‘ Формирование списка диаграмм

For Each crt In ActiveWorkbook.Charts

strMessage = strMessage & crt.Name & vbNewLine

‘ Отображение списка

MsgBox strMessage

End Sub

Применение случайной цветовой палитры

Листинг 5.9. Случайная цветовая палитра

Sub RandomChartColors()

Dim intGradientStyle As Integer, intGradientVariant As Integer

Dim i As Integer

‘ Проверка, выделена ли диаграмма

If ActiveChart Is Nothing Then Exit Sub

‘ Изменение оформления всех категорий

For i = 1 To ActiveChart.SeriesCollection.Count

With ActiveChart.SeriesCollection(i)

‘ Вид градиентной заливки (случайный)

intGradientStyle = Int(Rnd * 7) + 1

If intGradientStyle = 6 Then intGradientStyle = 1

If intGradientStyle = 7 Then

intGradientVariant = Int(Rnd * 2) + 1

Else

intGradientVariant = Int(Rnd * 4) + 1

End If

‘ Применение градиента

.Fill.TwoColorGradient Style:=intGradientStyle, _

Variant:=intGradientVariant

‘ Установка случайных цветов фона и обводки (используются _

для градиента)

.Fill.ForeColor.SchemeColor = Int(Rnd * 57) + 1

.Fill.BackColor.SchemeColor = Int(Rnd * 57) + 1

End With

Next i

End Sub

Эффект прозрачности диаграммы

Листинг 5.10. Эффект прозрачности диаграммы

Sub TransparentChart()

Dim shpShape As Shape

Dim dblColor As Double

Dim srSerie As Series

Dim intBorderLineStyle As Integer

Dim intBorderColorIndex As Integer

Dim intBorderWeight As Integer

‘ Проверка, есть ли выделенная диаграмма

If ActiveChart Is Nothing Then Exit Sub

‘ Изменение отображения каждой категории

For Each srSerie In ActiveChart.SeriesCollection

If (srSerie.ChartType = xlColumnClustered Or _

srSerie.ChartType = xlColumnStacked Or _

srSerie.ChartType = xlColumnStacked100 Or _

srSerie.ChartType = xlBarClustered Or _

srSerie.ChartType = xlBarStacked Or _

srSerie.ChartType = xlBarStacked100) Then

‘ Сохранение прежнего цвета категории

dblColor = srSerie.Interior.Color

‘ Сохранение стиля линий

intBorderLineStyle = srSerie.Border.LineStyle

‘ Цвет границы

intBorderColorIndex = srSerie.Border.ColorIndex

‘ Толщина линий границы

intBorderWeight = srSerie.Border.Weight

‘ Создание автофигуры

Set shpShape = ActiveSheet.shapes.AddShape _

(msoShapeRectangle, 1, 1, 100, 100)

With shpShape

‘ Закрашиваем нужным цветом

.Fill.ForeColor.RGB = dblColor

‘ Делаем прозрачной

.Fill.Transparency = 0.4

‘ Убираем линии

.Line.Visible = msoFalse

End With

‘ Копируем автофигуру в буфер обмена

shpShape.CopyPicture Appearance:=xlScreen, _

Format:=xlPicture

‘ Вставляем автофигуру в изображения столбцов _

категории и настраиваем

With srSerie

‘ Собственно вставка

.Paste

‘ Возвращаем на место толщину линий

.Border.Weight = intBorderWeight

‘ Стиль линий

.Border.LineStyle = intBorderLineStyle

‘ Цвет границы

.Border.ColorIndex = intBorderColorIndex

End With

‘ Автофигура больше не нужна

shpShape.Delete

End If

Next srSerie

End Sub

Построение диаграммы на основе данных нескольких рабочих листов

Листинг 5.11. Одновременное создание нескольких диаграмм

Sub ManyCharts()

Dim intTop As ****, intLeft As ****

Dim intHeight As ****, intWidth As ****

Dim sheet As Worksheet

Dim lngFirstRow As **** ‘ Первая строка с данными

Dim intSerie As Integer ‘ Текущая категория диаграммы

Dim strErrorSheets As String ‘ Список листов, для которых _

не удалось построить диаграммы

intTop = 1 ‘ Верхняя точка первой диаграммы

intLeft = 1 ‘ Левая точка каждой диаграммы

intHeight = 180 ‘ Высота каждой диаграммы

intWidth = 300 ‘ Ширина каждой диаграммы

‘ Постоение диаграммы для каждого листа, кроме текущего

For Each sheet In ActiveWorkbook.Worksheets

If sheet.Name <> ActiveSheet.Name Then

‘ Первый заполненный ряд

lngFirstRow = 3

‘ Первая категория

intSerie = 1

On Error GoTo DiagrammError

‘ Добавление и настройка диаграммы

With ActiveSheet.ChartObjects.Add _

(intLeft, intTop, intWidth, intHeight).Chart

Do Until IsEmpty(sheet.Cells(lngFirstRow + intSerie, 1))

‘ Создание ряда

.SeriesCollection.NewSeries

‘ Значения для ряда

.SeriesCollection(intSerie).Values = _

sheet.Range(sheet.Cells(lngFirstRow + intSerie, 2), _

sheet.Cells(lngFirstRow + intSerie, 4))

‘ Диапазон данных для подписей

.SeriesCollection(intSerie).XValues = _

sheet.Range(«B3:D3»)

‘ Название ряда (берется из столбца «A» таблицы с данными)

.SeriesCollection(intSerie).Name = sheet.Cells( _

lngFirstRow + intSerie, 1)

intSerie = intSerie + 1

Loop

‘ Настройка внешнего вида диаграммы

.ChartType = xl3DColumnClustered

.ChartGroups(1).GapWidth = 20

.PlotArea.Interior.ColorIndex = xlNone

.ChartArea.Font.Size = 9

‘ Диаграмма с легендой

.HasLegend = True

‘ Заголовок

.HasTitle = True

.ChartTitle.Characters.Text = sheet.Range(«A1»)

‘ Задание диапазона значений на осях

.Axes(xlValue).MinimumScale = 0

.Axes(xlValue).MaximumScale = 120000

‘ Стиль линий сетки (прерывистый)

.Axes(xlValue).MajorGridlines.Border. _

LineStyle = xlDot

End With

On Error GoTo 0

‘ Сдвиг верхней точки следующей диаграммы на высоту _

текущей диаграммы

intTop = intTop + intHeight

AfterError:

End If

Next sheet

If strErrorSheets <> «» Then

‘ Отобразим список листов, для которых не построили диаграммы

MsgBox «Не удалось построить диаграммы для листов:» & Chr(13) _

& strErrorSheets, vbExclamation

End If

Exit Sub

DiagrammError:

‘ Добавление в список имени листа, для которого не смогли _

построить диаграмму (ошибка в данных для диаграммы)

strErrorSheets = strErrorSheets & sheet.Name & Chr(13)

‘ Удаление пустой диаграммы на текущем листе

ActiveSheet.ChartObjects(ActiveSheet.ChartObjects.Count).Delete

‘ Продолжаем работу с другими листами

Resume AfterError

End Sub

Создание подписей к данным диаграммы

Листинг 5.12. Подписи к данным диаграммы

Sub ShowLabels()

Dim rgLabels As Range ‘ Диапазон с подписями

Dim chrChart As Chart ‘ Диаграмма

Dim intPoint As Integer ‘ Точка, для которой добавляется подпись

‘ Определение диаграммы

Set chrChart = ActiveSheet.ChartObjects(1).Chart

‘ Запрос на ввод диапазона с исходными данными

On Error Resume Next

Set rgLabels = Application.InputBox _

(prompt:=»Укажите диапазон с подписями», Type:=8)

If rgLabels Is Nothing Then Exit Sub

On Error GoTo 0

‘ Добавление подписей

chrChart.SeriesCollection(1).ApplyDataLabels _

Type:=xlDataLabelsShowValue, _

AutoText:=True, _

LegendKey:=False

‘ Просмотр диапазона и назначение подписей

For intPoint = 1 To chrChart.SeriesCollection(1).Points.Count

chrChart.SeriesCollection(1). _

Points(intPoint).DataLabel.Text = rgLabels(intPoint)

Next intPoint

End Sub

Sub DeleteLabels()

‘ Удаление подписей диаграммы

ActiveSheet.ChartObjects(1).Chart.SeriesCollection(1). _

HasDataLabels = False

End Sub

ГЛАВА 10. РАЗНЫЕ ПРОГРАММЫ.

Программа для составления кроссвордов

Листинг 6.1. Программа для составления кроссворда

Const dhcMinCol = 1 ‘ Номер первого столбца кроссворда

Const dhcMaxCol = 35 ‘ Номер последнего столбца кроссворда

Const dhcMinRow = 1 ‘ Номер первой строки кроссворда

Const dhcMaxRow = 35 ‘ Номер последней строки кроссворда

Sub Clear()

‘ Выделение и очистка всех используемых для кроссворда ячеек

Range(Cells(dhcMinRow, dhcMinCol), _

Cells(dhcMaxRow, dhcMaxCol)).Select

Selection.Clear

‘ Удаление сетки всего кроссворда

ClearGrid

Range(«A1»).Select

End Sub

Sub ClearGrid()

‘ Удаление сетки кроссворда (в выделенных ячейках)…

‘ Возврат прежнего цвета ячеек

Selection.Interior.ColorIndex = xlNone

‘ Задание начертания границ ячеек по умолчанию

Selection.Borders(xlDiagonalDown).LineStyle = xlNone

Selection.Borders(xlDiagonalUp).LineStyle = xlNone

Selection.Borders(xlEdgeLeft).LineStyle = xlNone

Selection.Borders(xlEdgeTop).LineStyle = xlNone

Selection.Borders(xlEdgeBottom).LineStyle = xlNone

Selection.Borders(xlEdgeRight).LineStyle = xlNone

Selection.Borders(xlInsideVertical).LineStyle = xlNone

Selection.Borders(xlInsideHorizontal).LineStyle = xlNone

End Sub

Sub DrowCrosswordGrid()

‘ Процедура начертания сетки кроссворда

‘ Задание цвета всех ячеек кроссворда

Selection.Interior.ColorIndex = 35

‘ Линии по диагонали не нужны

Selection.Borders(xlDiagonalDown).LineStyle = xlNone

Selection.Borders(xlDiagonalUp).LineStyle = xlNone

‘ Задание начертания границ всех диапазонов, входящих _

в выделение, а также границ между соседними ячейками _

всех диапазонов

On Error Resume Next

‘ Левые границы

With Selection.Borders(xlEdgeLeft)

.LineStyle = xlContinuous

.Weight = xlThin

.ColorIndex = xlAutomatic

End With

‘ Правые границы

With Selection.Borders(xlEdgeRight)

.LineStyle = xlContinuous

.Weight = xlThin

.ColorIndex = xlAutomatic

End With

‘ Верхние границы

With Selection.Borders(xlEdgeTop)

.LineStyle = xlContinuous

.Weight = xlThin

.ColorIndex = xlAutomatic

End With

‘ Нижние границы

With Selection.Borders(xlEdgeBottom)

.LineStyle = xlContinuous

.Weight = xlThin

.ColorIndex = xlAutomatic

End With

‘ Вертикальные границы между ячейками

With Selection.Borders(xlInsideVertical)

.LineStyle = xlContinuous

.Weight = xlThin

.ColorIndex = xlAutomatic

End With

‘ Горизонтальные границы между ячейками

With Selection.Borders(xlInsideHorizontal)

.LineStyle = xlContinuous

.Weight = xlThin

.ColorIndex = xlAutomatic

End With

End Sub

Sub DisplayGrid()

‘ Включение сетки на листе

ActiveWindow.DisplayGridlines = True

End Sub

Sub HideGrid()

‘ Выключение сетки на листе

ActiveWindow.DisplayGridlines = False

End Sub

Sub AutoNumber()

‘ Нумерация клеток, являющихся началом слов

Dim intRow As Integer ‘ Текущая строка

Dim intCol As Integer ‘ Текущий ряд

Dim cell As Range ‘ Текущая ячейка (с координатами _

(intRow, intCol))

Dim fTop As Boolean ‘ = True, если cell имеет соседей сверху

Dim fBottom As Boolean ‘ = True, если cell имеет соседей снизу

Dim fLeft As Boolean ‘ = True, если cell имеет соседей слева

Dim fRight As Boolean ‘ = True, если cell имеет соседей справа

Dim intDigit As Integer ‘ Текущий номер слова в кроссворде

intDigit = 1 ‘ Нумерация слов с 1

‘ Проходим по всем клеткам диапазона, используемого _

для кроссворда, сверху вниз слева направо и анализируем _

каждую угловую и крайнюю (левую и верхнюю) ячейки

For intRow = dhcMinRow To dhcMaxRow

For intCol = dhcMinCol To dhcMaxCol

‘ Текущая ячейка

Set cell = Cells(intRow, intCol)

‘ Проверка, входит ли ячейка в кроссворд (по ее цвету)

If cell.Interior.ColorIndex = 35 Then

fLeft = False

fRight = False

fTop = False

fBottom = False

On Error Resume Next

‘ Определение наличия соседей у ячейки…

‘ сверху

fTop = cell.Offset(-1, 0).Interior.ColorIndex = 35

‘ снизу

fBottom = cell.Offset(1, 0).Interior.ColorIndex = 35

‘ слева

fLeft = cell.Offset(0, -1).Interior.ColorIndex = 35

‘ справа

fRight = cell.Offset(0, 1).Interior.ColorIndex = 35

On Error GoTo 0

‘ Анализ положения ячейки

If (Not fTop And Not fLeft) Or _

(Not fBottom And Not fLeft And fRight) Or _

(Not fLeft And fRight) Or _

(Not fTop And fBottom) Then

‘ Ячейка подходит для начала слова

SetDigit intDigit, cell

intDigit = intDigit + 1

End If

Next intCol

Next intRow

End Sub

Sub SetDigit(intDigit As Integer, cell As Range)

‘ Вставка цифры intDigit в ячейку, заданную параметром cell

cell.Value = intDigit

‘ Изменение настроек шрифта так, чтобы было похоже _

на настоящий кроссворд

‘ Маленький размер шрифта

cell.Font.Size = 6

‘ Выравнивание текста по левому верхнему углу ячейки

cell.HorizontalAlignment = xlLeft

cell.VerticalAlignment = xlTop

End Sub

Sub ToPrint()

‘ Удаление цветовой подсветки кроссворда

Cells.Interior.ColorIndex = xlNone

End Sub

Sub ToNumber()

‘ Закрытие первой формы и переход ко второй

UserForm1.Hide

UserForm2.Show

End Sub

Создать обложку DVD

Sub Обложка_DVD()

On Error Resume Next

Sheets(«Обложка»).Select

If Err > 0 Then GoTo 10 Else MsgBox («Такой лист уже присутствует в книге…»): Exit Sub

10:

Sheets.Add.Name = «Обложка» ‘ создаем новый лист в текущей книге с именем «Обложка»

Sheets(«Обложка»).Range(«A1»).Select ‘ становимся в ячейку А1

Application.Dialogs(xlDialoginsеrtPicture).Show ‘вызываем диологовое окно «Вставка рисунка из файла»

Selection.ShapeRange.LockAspectRatio = msoFalse ‘

‘ Selection.ShapeRange.Height = 530.25 ‘ подгоняем размеры под размеры коробки

‘ Selection.ShapeRange.Width = 726# ‘

Selection.ShapeRange.Height = 530.2 ‘ подгоняем размеры под размеры коробки

Selection.ShapeRange.Width = 724# ‘

Selection.ShapeRange.Rotation = 0# ‘

Selection.Locked = False ‘

With ActiveSheet.PageSetup ‘ разносим поля листа на максимальные расстояния

.LeftMargin = Application.InchesToPoints(0.17)

.RightMargin = Application.InchesToPoints(0.17)

.TopMargin = Application.InchesToPoints(0.27)

.BottomMargin = Application.InchesToPoints(0.27)

.HeaderMargin = Application.InchesToPoints(0.17)

.FooterMargin = Application.InchesToPoints(0.17)

.Zoom = 100

.FitToPagesWide = 1

.FitToPagesTall = 1

.Orientation = xlLandscape ‘ придаем листу горизантальное положение (АЛЬБОМНЫЙ)

End With

If MsgBox(«Печать текущего изображения», vbYesNo, «Вывод на печать») = vbYes Then Sheets(«Обложка»).PrintOut Copies:=1, Collate:=True

Application.DisplayAlerts = False ‘ Выключили системные сообщения…

If MsgBox(«Удалить лист ОБЛОЖКА», vbYesNo, «Удаление листа…») = vbYes Then Sheets(«Обложка»).Delete Else Application.CommandBars(«Picture»).Visible = True

Application.DisplayAlerts = True ‘Включили системные сообщения…

End Sub

Игра «Минное поле»

Листинг 6.2. Код в модуле рабочего листа

Sub Worksheet_Selectiоnchange(ByVal Target As Range)

Dim intCol As Integer, intRow As Integer

Dim intMinesAround As Integer

Dim fInGameField As Boolean

‘ Определим, попадает ли в игровое поле выделенная ячейка

fInGameField = (Target.Row >= 2) And (Target.Row <= 7) _

And (Target.Column >= 2) And (Target.Column <= 7)

‘ Обрабатываем выделение ячейки

If Target.Value = «*» And fInGameField Then

‘ Пользователь выделил ячейку с миной — покажем мину

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

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

‘ Пользователь проиграл!

EndGame

ElseIf fInGameField Then

‘ Пользователь выделил пустую ячейку. Оформим эту ячейку

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

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

Target.Font.Size = 16

‘ Подсчитаем количество мин рядом с ячейкой (вокруг ячейки)

For intCol = Target.Column — 1 To Target.Column + 1

For intRow = Target.Row — 1 To Target.Row + 1

If Target.Worksheet.Cells(intRow, intCol).Value = «*» _

Then

‘ Нашли очередную мину

intMinesAround = intMinesAround + 1

End If

‘ Отображение количества мин

Target.Value = intMinesAround

End If

End Sub

Листинг 6.3. Код в стандартном модуле

Sub NewGame()

‘ Начало новой игры

‘ Подготовим поле для игры

InitGame

Dim intRow As Integer, intCol As Integer

Dim intMinesCount As Integer ‘ Количество мин

‘ Расставляем мины (то есть в случайные ячейки помещаем _

значения «*» и делаем цвет шрифта таким же, как цвет _

фона этих ячеек)

For intMinesCount = 1 To 10

‘ Строка для мины (от 2 до 7)

intRow = Int((6 * Rnd) + 1) + 1

‘ Столбец для мины (от 2 до 7)

intCol = Int((6 * Rnd) + 1) + 1

‘ Ставим мину, если ячейка пустая

If Cells(intRow, intCol) <> «*» Then

Cells(intRow, intCol).Font.Color = _

Cells(intRow, intCol).Interior.Color

Cells(intRow, intCol).Value = «*»

Else

‘ В данной ячейке мина есть — продолжим поиск ячеек

intMinesCount = intMinesCount — 1

End If

‘ Вывод информации о количестве мин в строку состояния

Application.StatusBar = «Количество мин » & intMinesCount

End Sub

Sub InitGame()

‘ Раскраска (оформление) листа перед началом игры

Dim intRow As Integer, intCol As Integer

‘ Цвет фона всех ячеек

Cells.Interior.Color = RGB(0, 200, 75)

‘ Цвет шрифта всех ячеек

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

‘ Размер шрифта

Cells.Font.Size = 18

‘ Все надписи — по центру

Cells.HorizontalAlignment = xlCenter

‘ Всем ячейкам игрового поля назначим особый цвет

For intRow = 2 To 7

For intCol = 2 To 7

Cells(intRow, intCol).Interior.Color = RGB(200, 200, 200)

Cells(intRow, intCol).Value = «»

End Sub

Sub EndGame()

‘ Завершение игры (поражение)

Dim intRow As Integer, intCol As Integer

‘ Покажем все мины. Для этого сделаем цвет шрифта всех ячеек _

черным (ведь во всех ячейках с минами «*» цвет шрифта и цвет _

заливки одинаковы)

For intRow = 2 To 7

For intCol = 2 To 7

If Cells(intRow, intCol).Value = «*» Then

Cells(intRow, intCol).Font.Color = RGB(0, 0, 0)

End If

MsgBox «Проигрыш»

End Sub

Игра «Угадай животное»

Листинг 6.4. Игра «Угадай животное»

Sub StartGame()

Dim intLastRow As Integer ‘ Номер строки для вставки записей

Dim intRow As Integer ‘ Номер текущей строки

Dim intYesRow As Integer ‘ Номер строки, из которой брать _

данные при утвердительном ответе

Dim intNoRow As Integer ‘ Номер строки, из которой брать _

данные при отрицательном ответе

Dim strText As String ‘ Строка с вопросом или названием _

животного

Dim strNewName As String ‘ Строка с названием нового животного

Dim strNewQuestion As String ‘ Строка с новым вопросом

Dim intRes As Integer

‘ Начало игры

MsgBox «Начнем игру. Задумайте животное.», vbOKOnly, _

«Задумайте животное»

‘ Определение номера ряда для вставки записей. _

intLastRow-1 — номер последнего ряда, содержащего данные

intLastRow = Worksheets(«Data»).Range(«D1»).Value + 1

‘ Данные в таблице идут с первого ряда

intRow = 1

Do While intRow < intLastRow

‘ Текст вопроса или название животного из столбца «A»

strText = Worksheets(«Data»).Cells(intRow, 1).Value

‘ Номер ряда, из которого брать данные при утвердительном _

ответе, берем из столбца «B»

intYesRow = Worksheets(«Data»).Cells(intRow, 2).Value

‘ Номер ряда, из которого брать данные при отрицательном _

ответе, берем из столбца «C»

intNoRow = Worksheets(«Data»).Cells(intRow, 3).Value

If intYesRow > 0 Then

‘ В строке strText содержится вопрос. Зададим его

intRes = MsgBox(strText, vbYesNo, «Вопрос»)

If intRes = vbYes Then

‘ Переходим по утвердительному ответу

intRow = intYesRow

Else

‘ Переходим по отрицательному ответу

intRow = intNoRow

End If

Else

‘ Альтернативы закончились. В строке strText — название _

животного. Спросим, его ли загадали

intRes = MsgBox(«Это » & strText & «?», vbYesNo, «Вопрос»)

If intRes = vbYes Then

‘ Животное угадано

MsgBox «Угадано! Спасибо за игру!», vbOKOnly, _

«Игра завершена»

Exit Do

Else

‘ Животное не угадали, но данные уже занкончились. _

Нужно пополнить наши данные, чтобы отличать животное _

с названием strText от загаданного

‘ Ввод названия нового животного

strNewName = InputBox(«Сдаюсь. Кто это?», _

«Напечатайте название животного»)

If strNewName <> «» Then

‘ Ввод вопроса, по которому отличать животных

strNewQuestion = InputBox(«Задайте вопрос, по » & _

«которому можно отличить ‘» & strNewName & _

«‘ от ‘» & strText & «‘», «Напечатайте вопрос»)

If strNewQuestion <> «» Then

‘ Определение, какое из животных соответствует _

утвердительному ответу на вопрос

intRes = MsgBox(«Правильный ответ на ваш » & _

«вопрос — » & strNewName & «‘», vbYesNo, _

«Какой ответ на вопрос?»)

‘ Добавление в таблицу названия нового животного

Worksheets(«Data»).Cells(intLastRow, 1). _

Value = strNewName

‘ Перемещения названия животного, которое было _

ранее, в конец таблицы

Worksheets(«Data»).Cells(intLastRow + 1, 1). _

Value = strText

‘ Замена названия этого животного вопросом

Worksheets(«Data»).Cells(intRow, 1). _

Value = strNewQuestion

‘ Корректировка номеров строк для перехода _

в зависимости от того, какое животное является _

правильным ответом на введенный пользователем вопрос

If intRes = vbYes Then

‘ Новое животное — правильный ответ

Worksheets(«Data»).Cells(intRow, 2). _

Value = intLastRow

Worksheets(«Data»).Cells(intRow, 3). _

Value = intLastRow + 1

Else

‘ Бывшее ранее животное — правильный ответ

Worksheets(«Data»).Cells(intRow, 2). _

Value = intLastRow + 1

Worksheets(«Data»).Cells(intRow, 3). _

Value = intLastRow

End If

‘ Сохраним номер строки для добавления записей

Worksheets(«Data»).Range(«D1»).Value = _

intLastRow + 2

End If

‘ Игра завершена. Таблица дополнена

MsgBox «Спасибо за игру!», vbOKOnly, «Игра завершена»

Exit Do

End If

Loop

End Sub

Расчет на основании ячеек определенного цвета

Листинг 6.5. Код в стандартном модуле

Const dhcSum As Integer = 0

Const dhcAvg As Integer = 1

Const dhcMax As Integer = 2

Const dhcMin As Integer = 3

Const dhcCount As Integer = 4

Const dhcSumPlus As Integer = 5

Const dhcSumMinus As Integer = 6

Const dhcCountFull As Integer = 7

Const dhcCountNotNull As Integer = 8

Const dhcCountPlus As Integer = 9

Const dhcCountMinus As Integer = 10

Sub CalcColors()

‘ Отображение формы

Load frmColorCalc

frmColorCalc.Show

End Sub

Public Function ColorCalc(strRange As String, _

lngColor As ****, fBackBolor As Boolean, _

intMode As Integer, Optional fAbsence As Boolean) As Double

‘ Операции над ячейками с установленным цветом шрифта _

или заливки

Dim rgData As Range ‘ Диапазон ячеек для расчетов

Dim i As Integer

Dim Values() As Variant ‘ Массив со значениями для расчета

Dim intCount As Integer ‘ Количество значений в массиве

Dim cell As Range

Dim varOut As Variant ‘ В этой переменной хранятся _

результаты промежуточных подсчетов _

и окончательный результат

Set rgData = Range(strRange)

ReDim Values(1 To rgData.Count)

‘ Просматриваются все ячейки входного диапазона. Значения тех из них, _

цвет которых удовлетворяет условию, записываются в массив Values

For Each cell In rgData.Cells

‘ Если нужно суммировать по заливке:

If fBackBolor = True Then

‘ Включение ячейки в сумму в зависимости от цвета _

заливки и фильтра

If fAbsence Then

‘ Если ячейка имеет заданный цвет, то она не включается _

в вычисления

If cell.Interior.Color <> lngColor Then

intCount = intCount + 1

Values(intCount) = cell.Value

End If

Else

‘ Если ячейка имеет заданный цвет, то она включается _

в вычисления

If cell.Interior.Color = lngColor Then

intCount = intCount + 1

Values(intCount) = cell.Value

End If

‘ В противном случае — суммируется по шрифту

Else

‘ Включение ячейки в сумму в зависимости _

от ее цвета и фильтра

If fAbsence Then

‘ Если ячейка имеет заданный цвет, то она не включается _

в вычисления

If cell.Font.Color <> lngColor Then

intCount = intCount + 1

Values(intCount) = cell.Value

End If

Else

‘ Если ячейка имеет заданный цвет, то она включается _

в вычисления

If cell.Font.Color = lngColor Then

intCount = intCount + 1

Values(intCount) = cell.Value

End If

Next cell

‘ Выполнение над собранными значениями операции, заданной в intMode

For i = 1 To intCount

Select Case intMode

Case dhcSum, dhcAvg

‘ Подсчет суммы значений

varOut = varOut + Values(i)

Case dhcSumPlus

‘ Подсчет суммы положительных значений

If Values(i) > 0 Then varOut = varOut + Values(i)

Case dhcSumMinus

‘ Посчет суммы отрицательных значений

If Values(i) < 0 Then varOut = varOut + Values(i)

Case dhcMax

‘ Нахождение максимального значения

If Values(i) > varOut Then varOut = Values(i)

Case dhcMin

‘ Нахождение минимального значения

If i = LBound(Values) Then varOut = Values(i)

If Values(i) < varOut Then varOut = Values(i)

Case dhcCount

‘ Подсчет количества значений

varOut = varOut + 1

Case dhcCountFull

‘ Подсчет количества заполненных ячеек

If Not IsEmpty(Values(i)) Then varOut = varOut + 1

Case dhcCountNotNull

‘ Подсчет количества пустых ячеек

If Not IsEmpty(Values(i)) And Values(i) <> 0 Then _

varOut = varOut + 1

Case dhcCountPlus

‘ Подсчет количества положительных значений

If Values(i) > 0 Then varOut = varOut + 1

Case dhcCountMinus

‘ Подсчет количества отрицательных значений

If Values(i) < 0 Then varOut = varOut + 1

End Select

Next i

‘ Окончательные операции для некоторых видов расчета

If intMode = dhcAvg Then

‘ Вычисление среднего значения

ColorCalc = varOut / intCount

Else

ColorCalc = varOut

End If

End Function

Листинг 6.6. Код в модуле формы

Dim lngCurColor As **** ‘ Выбранный цвет, по которому _

идентифицировать (отбирать) ячейки

Dim intMode As Integer ‘ Номер типа вычисления в списке

Sub cmbApplyColor_Click()

If cboOtherColor.Value >= 0 Then

‘ Вычисление с использованием выбранного в списке цвета

lngCurColor = cboOtherColor.Value

SetColorSum

End If

End Sub

Sub cmbColor1_Click()