Секреты программирования

Word Поиск и замена в нескольких файлах (VBA)

2011-08-03T17:55:00.000+03:00

Данный код поможет заменить определенную строку в нескольких файлах Word одновременно.
Например это может пригодится, если необходимо заменить номер счета или телефона в корпоративных бланках и т.д.

Скачать макрос замены в нескольких файлах Word

Инструмент сделан на основе документа Word, с помощью кода VBA. Внешне документ выглядит так:

Два поля, с привязанными Bookmark-ами (SearchFor и ReplaceWith) позволяют обратиться к ним из кода:

    searchFor = ThisDocument.Bookmarks("SearchFor").Range.Text
    replaceWith = ThisDocument.Bookmarks("ReplaceWith").Range.Text

Кнопка вызывает стандартный диалог выбора файлов. Для обработки файлов создается отдельный объект Word, который на всякий случай делается видимым:

    Set wordApp = New Application
    wordApp.Visible = True

Выключаются предупреждения:

    Application.DisplayAlerts = wdAlertsNone
    wordApp.DisplayAlerts = wdAlertsNone

Все файлы последовательно открываются, обрабатываются в цикле и закрываются с сохранением.

    For Each FileName In picker.items
        Set wordDocument = wordApp.Documents.Open(FileName)
        With wordDocument.Content.Find
            .Text = searchFor
            .Replacement.Text = replaceWith
            .Forward = True
            .MatchCase = False
            .Execute Replace:=wdReplaceAll
        End With
        wordDocument.Close SaveChanges:=True
    Next

Внедрение скрипта VBScript в EXE-файл (C#)

2011-08-01T11:35:00.004+03:00

Создаем пустой консольный проект в C#.

Затем добавляем файл скрипта в ресурсы проэкта
В VS2010 это можно сделать через:
RMB на имени проекта->Properties->Resources->Add Resource->Add New Text File

Теперь можно получить содержимое скрипта, сохранить и запустить его.
Исходный код достаточно прост.

Чтобы получить содержимое скрипта, я использую:

Properties.Resources.MyEmbeddedScript

где MyMbeddedScript - имя ресурса со скриптом.

Получить случайное, временное имя файла для сохранения скрипта:

string scriptFileName = Path.GetTempFileName().Replace(".tmp",".vbs");

Сохранение и запуск скрипта:

File.WriteAllText(scriptFileName, content);
startedProcess = Process.Start(scriptFileName);

Чтобы запустить скрипт под другим пользователем, можно использовать следующий метод:
RunAs без ввода пароля

Аналогичным способом можно превратить любой скрипт (.vbs, .js, .ahk и т.д) в исполняемый .exe-файл.

Исходный код программы:

using System;
using System.Security;
using System.Diagnostics;
using System.IO;

namespace scriptEmbed
{
    class Program
    {
        static int Main(string[] args)
        {
            return RunScript(Properties.Resources.MyEmbeddedScript);
        }
        static int RunScript(string content)
        {
            string scriptFileName = Path.GetTempFileName().Replace(".tmp",".vbs");
            Process startedProcess;
            try
            {
                File.WriteAllText(scriptFileName, content);
                startedProcess = Process.Start(scriptFileName);
                
                while (!startedProcess.HasExited) ;

                File.Delete(scriptFileName);
                
                return startedProcess.ExitCode;
            }
            catch (Exception e)
            {
                Console.WriteLine(e.Message);
                return 1;
            }
        }
        static string GetTempFolder()
        {
            return System.Environment.GetEnvironmentVariable("TEMP");
        }
    }

}

Утилита RunAs с паролем в командной строке (C#)

2011-07-31T16:10:00.002+03:00

Альтернатива стандартной утилите RunAs с возможностью задать пароль в командной строке.

Программа делает то-же самое, что и стандартная runas.exe. Единственное отличие - возможность указать пароль напрямую, в командной строке.

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

Скачать утилиту RunAs с паролем в командной строке

Синтаксис командной строки:
runasuser [-u пользователь] [-p пароль] [-d домен] someprogram.exe [параметры программы]

Ниже приведен полный исходный код:

using System;
using System.Diagnostics;
using System.Security;

namespace RunAsUser
{
    class Program
    {
        static int Main(string[] args)
        {
            string username = "", password = "", domain = "", apppath = "", arguments = "";

            for( int i=0; i<args.Length; i++)
            {
                switch (args[i].ToLower())
                {
                    case "-u":
                        username = args[++i];
                        break;
                    case "-p":
                        password = args[++i];
                        break;
                    case "-d":
                        domain = args[++i];
                        break;
                    default:
                        if (apppath == "")
                            apppath = args[i];
                        else
                            arguments += args[i] + (i<args.Length?" ":"");
                        break;
                }
            }

            if (args.Length == 0 || apppath == "" )
            {
                Console.WriteLine("\nCommand line syntax:\nrunasuser [-u user] [-p password] [-d domain] someprogram.exe [params]\n");
                return 1;
            }
            Console.WriteLine(arguments);
            return RunAs(apppath, arguments, domain, username, password);

        }
        static int RunAs(string apppath, string arguments, string domain, string username, string password)
        {
            Process userProcess;
            try
            {
                userProcess = Process.Start( apppath, arguments, username, GetSecure(password), domain);
                while (!userProcess.HasExited) ;
                return userProcess.ExitCode;
            }
            catch (Exception e)
            {
                Console.WriteLine(e.Message);
            }
            return -1;
        }

        static SecureString GetSecure(string str)
        {
            SecureString SecureStr = new SecureString();
            foreach (char c in str)
            {
                SecureStr.AppendChar(c);
            }

            return SecureStr;
        }
    }
}

Синхронизация Microsoft DNS с MySQL (VBScript)

2011-07-26T10:43:00.002+03:00

Иногда полезно иметь реплику записей DNS на сервере MySQL. Эти данные можно использовать для построения различных схем сети, подсчета компьютеров и т.д.

В данном примере я использовал WMI для синхронизации базы Microsoft DNS с MySQL сервером.

В начале скрипт делает полную копию базы DNS. Затем устанавливает обработчик для каждого из событий Создания/Изменения/Удаления

Каждое событие вносит изменения в MySQL. Такой подход позволяет иметь точную реплику записей DNS в MySQL без заметных задержек.

Скачать скрипт dnsmonitor.vbs

Исходный код можно увидеть ниже.
Не забудьте изменить имя NetBios сервера DNS и учетные данные MySQL в верху кода.

'NetBios имя DNS сервера
Const SERVERNAME = "SERVER"

'Учетные данные MySQL
Const host="localhost"
Const Db="system"
Const login= "user"
Const password="userpassword"

'Опции подключения к MySQL
Const MYDRIVER = "MySQL ODBC 5.1 Driver"
Const FLAG_BIG_PACKETS = 8 'Allow big results
Const FLAG_NO_PROMPT = 16 'Dont prompt anything
Const FLAG_DYNAMIC_CURSOR = 32 'Allow dynamic cursor
Const FLAG_COMPRESSED_PROTO = 2048 'Use compressed protocol
Const FLAG_NO_BIGINT = 16384 'Change bigint(8) to int(4)
Const FLAG_MULTI_STATEMENTS = 67108864 'Enable batch statements
Const FLAG_AUTO_RECONNECT = 4194304 'Auto reconnect

'ADODB connection
Dim conn

'Создание глобальных объектов
Set oFSO = CreateObject("Scripting.FileSystemObject")
Set objWMIService = GetObject("winmgmts:{impersonationLevel=impersonate}\\" & SERVERNAME & "\root\MicrosoftDNS")
Set objSink = WScript.CreateObject("WBemScripting.SWbemSink","event_")
Set objShell = CreateObject("WScript.Shell")

'Выход, если уже запущен
Set oProcess = Nothing
If alreadyRunning() Then: WScript.Quit

If Not MySQLConnect() Then
WScript.Quit
Else
PrepareDatabase
End If

'Инициализация таблицы
MySQLExecute "DELETE FROM dns_cache"
Set dnsRecords = objWMIService.ExecQuery( "SELECT * FROM MicrosoftDNS_AType", "WQL", 48 )
For Each objRecord in dnsRecords
domain = objRecord.DomainName
name = Replace(objRecord.OwnerName,domain,"")
ip = objRecord.IPAddress 
ttl = objRecord.TTL
timestamp = objRecord.Timestamp
OnCreation domain,name,ip,timestamp,ttl
Next

'Установка обработчика событий
objWMIService.ExecNotificationQueryAsync objSink, "Select * from __InstanceOperationEvent within 1 where TargetInstance ISA 'MicrosoftDNS_AType'"

'Бесконечный цикл
Do
WScript.Sleep 1000
Loop

'Обработчик событий
Sub event_OnObjectReady( objEvent, objContext )
With objEvent
domain = objEvent.TargetInstance.DomainName
name = Replace(objEvent.TargetInstance.OwnerName,domain,"")
ip = objEvent.TargetInstance.IPAddress 
ttl = objEvent.TargetInstance.TTL
timestamp = objEvent.TargetInstance.timestamp
if name <> "" Then
Select Case .Path_.Class
Case "__InstanceModificationEvent"
OnModify domain,name,ip,timestamp,ttl
Case "__InstanceCreationEvent"
OnCreation domain,name,ip,timestamp,ttl
Case "__InstanceDeletionEvent"
OnDeletion domain,name,ip
End Select
End If
End With
End Sub

'Обработчик для события изменения
Sub OnModify( domain, name,ip,timestamp,ttl )
update = "domainname='" & domain & "',hostname='" & name & "',ipaddress=inet_aton('" & ip & "')," & _ 
"refreshon=IF(" & timestamp & "=0,Null,'1601-01-01 00:00') + INTERVAL " & timestamp & " HOUR,ttl=" & ttl
MySQLExecute "INSERT INTO dns_cache SET " & update & " ON DUPLICATE KEY UPDATE " & update
End Sub

'Обработчик для события создания
Sub OnCreation( domain, name,ip,timestamp,ttl )
update = "domainname='" & domain & "',hostname='" & name & "',ipaddress=inet_aton('" & ip & "')," & _
"refreshon=IF(" & timestamp & "=0,Null,'1601-01-01 00:00') + INTERVAL " & timestamp & " HOUR,ttl=" & ttl
MySQLExecute "INSERT INTO dns_cache SET " & update & " ON DUPLICATE KEY UPDATE " & update 
End Sub

'Обработчик для события удаления
Sub OnDeletion( domain, name,ip )
MySQLExecute "DELETE FROM dns_cache WHERE hostname='" & name & "' AND ipaddress=inet_aton('" & ip & "') AND domainname='" & domain & "'"
End Sub

'Создание базы данных, если еще не создана
Function PrepareDatabase
CreateDatabase = False
On Error Resume Next
MySQLExecute "CREATE DATABASE IF NOT EXISTS " & db & " CHARACTER SET utf8 COLLATE utf8_general_ci"
On Error Goto 0
MySQLExecute "USE " & db
MySQLExecute "CREATE TABLE IF NOT EXISTS dns_cache(" & _
"hostname VARCHAR(255) NOT NULL," & _
"domainname VARCHAR(255) NOT NULL," & _
"ipaddress INT(11) UNSIGNED NOT NULL," & _
"refreshon DATETIME DEFAULT NULL," & _
"ttl INT(11) NOT NULL DEFAULT 0," & _
"PRIMARY KEY (ipaddress, hostname, domainname)," & _
"INDEX IX_dns_cache_deadline (refreshon)," & _
"INDEX IX_dns_cache_domainname (domainname)," & _
"INDEX IX_dns_cache_ipaddress (ipaddress)," & _
"INDEX IX_dns_cache_name (hostname)," & _
"INDEX IX_dns_cache_ttl (ttl)" & _
") " & _
"ENGINE = INNODB " & _
"AVG_ROW_LENGTH = 68 " & _
"CHARACTER SET utf8 " & _
"COLLATE utf8_general_ci;"
If Err.Number <> 0 Then: CreateDatabase = True
End Function

Function alreadyRunning()
alreadyRunning = False
wscrCount = ProcessCount( "%wscript%" & WScript.ScriptName & "%" )
cscrCount = ProcessCount( "%cscript%" & WScript.ScriptName & "%" )
If wscrCount > 1 or cscrCount > 1 Then:alreadyRunning = True
End Function

Public Function ProcessCount(likestr)
Set objWMI = GetObject("winmgmts:{impersonationLevel=impersonate}\\.\root\cimv2")
Set colItems = objWMI.ExecQuery("SELECT Name,CommandLine FROM Win32_Process WHERE CommandLine Like '" & likestr & "'")
ProcessCount = colItems.Count
End Function 

'Процедуры MySQL
Function MySQLExecute( cmd )
On Error Resume Next
Set rst = conn.Execute( cmd )
If conn.Errors.Count > 0 Then
If conn.Errors(conn.Errors.Count-1).NativeError = 2006 Then 
conn.Errors.Clear
If InitConnection() Then
Set rst = conn.Execute( cmd )
End If
End If 
End If
If rst.State = 1 And Err.Number = 0 Then
Set MySQLExecute = rst
Else
Set MySQLExecute = conn.Execute( "SELECT Null LIMIT 0" )
End If
On Error Goto 0
End Function

Function MySQLConnect
Set conn = CreateObject("ADODB.Connection")
MySQLConnect = False
On Error Resume next
conn.ConnectionString = "DRIVER={" & MYDRIVER & "};" & _
"SERVER=" & host & ";" & _
"UID=" & login & ";" & _
"PWD=" & password & ";" & _
"OPTION=" & (FLAG_BIG_PACKETS + FLAG_COMPRESSED_PROTO + FLAG_NO_BIGINT + FLAG_MULTI_STATEMENTS)
conn.ConnectionTimeout = 3
conn.Open
If Err.Number = -2147467259 Then
MsgBox "MyODBC isn't installed. Can't connect to MySQL!"
Exit Function
End If
If Err.Number <> 0 Then
MsgBox err.description
Exit Function
End If
MySQLConnect = True
On Error GoTo 0
End Function

Sub MySQLDisconnect
conn.Close
Set conn = Nothing
End Sub

Мониторинг подключения/отключения USB устройств на VBScript

2011-07-16T17:07:00.000+03:00

Некоторое время назад у меня завялся телефон на Android. Чтобы управлять им с компьютера я установил MyPhoneExplorer.
Это отличная программа, но все-же в ней не хватает одной важной для меня функции, а именно: автоматического переподключения при подключении телефона к USB. С другой стороны в ней есть такая опция, как "Подключаться при запуске".
Отсюда у меня появилась идея написать скриптик, который будет прибивать процесс MyPhoneExplorer при отключении телефона и запускать при подключении.
Наконец я оформил это на VBScript. Этот скрипт наблюдает за подключением/отключением устройства под названием "Android ADB Interface" и выполняет соответствующие действия:

Const DEVICENAME = "Android ADB Interface"
Const EXENAME = "MyPhoneExplorer.exe"
Dim lastOperation
Set objWMIService = GetObject("winmgmts:{impersonationLevel=impersonate}\\.\root\cimv2")

'Выйти, если скрипт уже запущен
If alreadyRunning() Then: WScript.Quit

Set objSink = WScript.CreateObject("WBemScripting.SWbemSink","event_")
Set objShell = CreateObject("WScript.Shell")
Set deviceIDs = CreateObject("Scripting.Dictionary")

'Установим перехватчик событий
objWMIService.ExecNotificationQueryAsync objSink, "Select * from __InstanceOperationEvent within 1 where TargetInstance ISA 'Win32_PnPEntity'"

'Получим ID устройств по заданному имени
EnumerateDevices DEVICENAME
objShell.Popup "Мониторинг USB начат!",2
'Бесконечный цикл
Do
 WScript.Sleep 1000
Loop

'Перехватчик событий подключения/отключения USB устройств
Sub event_OnObjectReady( objEvent, objContext )
 With objEvent
  If deviceIDs.Exists(.TargetInstance.DeviceId) Then
   Select Case .Path_.Class
    Case "__InstanceCreationEvent"
     If lastOperation <> "Insert" Then
      lastOperation = "Insert"
      OnInsert
     End If
      
    Case "__InstanceDeletionEvent"
     If lastOperation <> "Remove" Then
      lastOperation = "Remove"
      OnRemove
     End If
    End Select
  End If
 End With
End Sub

Sub OnInsert
 objShell.Run EXENAME,1,0
End Sub

Sub OnRemove
 objShell.Run "taskkill /f /im " & EXENAME,0,0
End Sub

Sub EnumerateDevices(name)
 Set objDevices = objWMIService.ExecQuery("SELECT DeviceId FROM Win32_PnPSignedDriver WHERE Description='" & name & "'")
 For Each dev in objDevices
  deviceId = dev.DeviceId
  If Not deviceIDs.Exists(deviceId) Then
   deviceIDs.Add deviceId, deviceId
  End If
  d = d + 1
 Next
End Sub

Function alreadyRunning()
 alreadyRunning = False
 wscrCount = ProcessCount( "%wscript%" & WScript.ScriptName & "%" )
 cscrCount = ProcessCount( "%cscript%" & WScript.ScriptName & "%" )
 If  wscrCount > 1 or cscrCount > 1 Then:alreadyRunning = True
End Function

Public Function ProcessCount(likestr)
 Set colItems = objWMIService.ExecQuery("SELECT Name,CommandLine FROM Win32_Process WHERE CommandLine Like '" & likestr & "'")
 ProcessCount = colItems.Count
End Function

VBS-файл можно скачать здесь

Взлом пароля Excel. Макрос VBA, на основе Excel

2010-01-22T09:09:00.004+02:00

Существует простой способ взломать забытый пароль Excel. И что немаловажно, сделать это можно абсолютно бесплатно с помощью самого Excel.
Итак если файл открывается, но Вам необходимо убрать защиту листа или книги, используйте надстройку, которую я написал:

Скачать надстройку

Идея алгоритма заключается в использовании недостатка стандартного метода шифрования Excel. Программа перебирает пароли от 1 до 8 символов. Последний символ пароля подбирается из диапазона кодов от 32 до 255. Остальные символы подбираются из кодов 65 и 66. В результате используется пароль отличный от оригинального, но тем не менее рабочий. К сожалению для открытия файла, через Workbook.Open(), этот метод не подходит. Метод также не работает в Excel 2007, где используется более стойкий алгоритм шифрования. Исключение составляет французская версия Excel 2007, где из-за местных законов шифрование остается прежним.

Ниже приведен исходный код надстройки для взлома пароля в Excel:

Const MENUNAME = "ЗАЩИТА"
'Установка ярлыка меню
Sub Auto_Open()
    Install
    MsgBox "Меню установлено, используйте ""ЗАЩИТА->Снять защиту"" для снятия защиты с активной книги Excel и всех листов"
End Sub

'Взлом всех паролей, путем перебора.
Sub BruteForceUnprotect()
    Dim ProtectedObjects As New Collection
    Const LastCharStart = 32
    Const LastCharFinish = 255
    
    Application.DisplayAlerts = False
    
    'Добавление защищенной книги в набор объектов для вскрытия
    If (ActiveWorkbook.ProtectStructure Or ActiveWorkbook.ProtectWindows) Then
        ProtectedObjects.Add ActiveWorkbook
    End If
    
    'Добавление в набор защищенных листов
    On Error Resume Next
    For Each WSheet In ActiveWorkbook.Worksheets
        WSheet.Protect ("")
        If Not WSheet.Unprotect("") Then: ProtectedObjects.Add WSheet
    Next
    On Error GoTo 0
    
    'Поиск подставного пароля. Оригинальный пароль не может быть восстановлен этим способом.
    For i = 1 To 255
        fakepassword = FakePass(i)
        If ProtectedObjects.Count = 0 Then: Exit For
        For LastCharIndex = LastCharStart To LastCharFinish
            Password = fakepassword & Chr(LastCharIndex)
            If ProtectedObjects.Count > 0 Then
                For j = 1 To ProtectedObjects.Count
                    If UnprotectObject(ProtectedObjects(j), Password) = True Then
                        ProtectedObjects.Remove (j)
                        If ProtectedObjects.Count > 0 Then: j = j - 1
                    End If
                Next
            End If
        Next
    Next
    
    If ProtectedObjects.Count = 0 Then
        MsgBox "Пароли на текущую книгу и листы сняты!"
    Else
        MsgBox "Похоже используется нестандартное шифрование. Защита некоторых объектов не может быть снята."
    End If
    Application.DisplayAlerts = True
End Sub
Function UnprotectObject(obj, pass)
  UnprotectObject = False
  On Error GoTo WrongPassword
  obj.Unprotect pass
  UnprotectObject = True
WrongPassword:
End Function
'Возвращает пароль на основе переданного числового значения
Function FakePass(Value)
    Mask = 1
    FakePass = ""
    While Mask <= Value
        If (Value And Mask) = 0 Then
            FakePass = "A" & FakePass
        Else
            FakePass = "B" & FakePass
        End If
        Mask = Mask * 2
    Wend
    If Len(FakePass) > 0 Then: FakePass = Right(FakePass, Len(FakePass) - 1)
End Function
'Установка меню
Sub Install()
    Uninstall True
    AddButton MENUNAME, "Снять защиту", "BruteForceUnprotect"
    AddButton MENUNAME, "Удалить меню надстройки", "Uninstall"
End Sub
'Удаление меню надстройки
Sub Uninstall(Optional silent = False)
    If Not silent Then
        If MsgBox("Вы действительно желаете удалить меню надстройки ?", vbYesNo) = vbNo Then
            Exit Sub
        End If
    End If
    On Error Resume Next
    Application.CommandBars("Worksheet Menu Bar").Controls(MENUNAME).Delete
    On Error GoTo 0
End Sub
'Добавить пункт в меню
Sub AddButton(menu As String, submenu As String, macro As String, Optional descr As String = "")
    On Error GoTo createmenu
    If IsNull(Application.CommandBars("Worksheet Menu Bar").Controls(menu)) Then: GoTo createmenu
    On Error GoTo create
    If IsNull(Application.CommandBars("Worksheet Menu Bar").Controls(menu).Controls(submenu)) Then: GoTo create
    End
createmenu:
    Set mnu = Application.CommandBars("Worksheet Menu Bar").Controls.Add(Type:=10)
    mnu.Caption = "&" & menu
    mnu.Visible = True
    
create:
    Set Button = Application.CommandBars("Worksheet Menu Bar").Controls(menu).Controls.Add(Type:=1, ID:=2950)
    With Button
        .DescriptionText = descr
        .TooltipText = descr
        .Caption = "&" & submenu
        .Style = 3
        .OnAction = macro
    End With
End Sub

Взлом пароля в Word.

2010-01-20T13:22:00.001+02:00

Взломать пароль на чтение документа MS Word можно используя сам Word. Никаких дополнительных утилит для этого не требуется

Проделайте следующее:
1. Откройте документ.
2. Нажмите Alt+Shift+F11. Откроется Microsoft Script Editor.
3. Нажмите Ctrl+F и наберите "pass" (без кавычек) в поле Find what.

4. Нажмите Find Next. Поиск подсветит строку вида: <w:UnprotectPassword>1234F8E7</w:UnprotectPassword>

5. Выделите всю строку и удалите ее
6. Нажмите Ctrl+S чтобы сохранить документ
7. Закройте окно Microsoft Script Editor
8. Выберите Сервис->Снять защиту. Защита на чтение будет снята, после чего можно вносить изменения.

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

2010-01-19T08:44:00.000+02:00

В канонических учебниках по VBA, для Excel можно встретить пример получения последней ячейки вида:

Set LastCell = ActiveSheet.SpecialCells(xlLastCell)

В целом здесь все правильно, за исключением одного момента. Иногда, после вставки и очистки данных в конце листа, последняя ячейка оказывается пустой.
Тогда как на практике гораздо важнее получить последнюю ячейку в заполненном диапазоне. Используя свойство UsedRange это легко сделать.

Пример:

Set LastCell = ActiveSheet.UsedRange.SpecialCells(xlLastCell)

VBA. Чтение и запись в Excel. Оптимизация.

2010-01-18T09:34:00.002+02:00

1. Оптимизация с помощью Range.Resize()
Впервые столкнувшись с задачей программно прочитать содержимое ячеек Excel, многие используют самый очевидный способ: цикл чтений Cells(row,column).value.

Пример:

For i = 1 To 10
  destination.Cells(i,1).value = source.Cells(i,1).value 
Next

Не трудно заметить, что в данном примере было произведено 10 чтений.

Для ускорения чтения и записи данных из Excel, через VBA, всегда используйте метод класса Range: Resize(). Метод Resize() позволяет прочитать указанный диапазон ячеек в массив, для последующей обработки.

Пример:

arSales = Array()
arSales = source.Cells.Resize(10,1)

В данном примере, в массив arSales помещаются 10 строк и один столбец с листа source. По сравнению с чтением в цикле, данный метод работает в разы быстрее, поскольку чтение происходит за один этап. Таким-же образом данные помещаются в место назначения.

Пример:

destination.Cells.Resize(10,1) = arSales

Если имеется заданная переменная класса Range, то для получения массива можно просто использовать свойство Range.Value
Пример:

Set rng = Range("DATA")
arSales = rng.Value

2. Отключение вычислений на время записи данных.
При каждой записи ячейки Excel из кода VBA, программа автоматически пересчитывает все формулы в книге. Это вызывает серьезное замедление.
Для ускорения записи имеет смысл отключить автоматические вычисления и обновление экрана.

Пример:

Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Application.EnableEvents = False

После произведения необходимых действий в VBA, можно вернуть настройки.

Пример:

Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.EnableEvents = True

3. Использование условного форматирования.

Иногда необходимо заполнить и форматировать(раскрасить) таблицу Excel, используя VBA. Для решения этой задачи есть два способа.
Первый, "в лоб": форматировать каждую ячейку или диапазон ячеек в цикле непосредственно из программы. У этого способа два недостатка: скорость и неудобство форматирования.

Второй, оптимизированный способ: задать условное форматирование для заполняемого диапазона. Например, в условном форматировании можно проверять одно или несколько значений в заполняемой строке и если оно не пустое, форматировать всю строку. Таким образом при вставке значений в новую строку, из VBA, формат (цвет, шрифт) будет меняться автоматически, вне кода. Этот способ оптимален по скорости и удобен тем, что форматирование производится визуально.

Для реализации этого метода можно создать xls-файл, с заголовком и одной строкой, с заданным условным форматированием. Формат этой строки необходимо скопировать в строки, которые будут заполнятся. Поскольку задать формат одновременно для большого кол-ва ячеек нельзя, то делать это придется блоками.

Пример:

rowscount = 20000 ' Кол-во форматируемых строк
colscount= 5 ' Кол-во форматируемых столбцов
onepass = 1024 ' Кол-во строк форматируемых за один проход
src_row = 1 ' Номер строки с заданным условным форматированием
For i = src_row+1 To rowscount Step onepass
  Rows(src_row).Resize(1, colscount).Copy
  If i + onepass > rowscount Then: onepass = rowscount - i
  Rows(i).Resize(onepass, colscount).PasteSpecial _ 
    Paste:=xlPasteFormats, _
    Operation:=xlNone, _
    SkipBlanks:=False, _ 
    Transpose:=False
Next

Теперь можно вставлять значения. Настройки цвета и шрифта будут применяться автоматически.