Макросы и программы для Excel в категории «Создание файлов». Vba создать excel файл

Программы и макросы Excel в категории Создание файлов

Надстройка FillDocuments предназначена для формирования (подготовки) документов по шаблонам, с заполнением созданных файлов данными из текущей книги Excel, с возможностью отправки писем. В качестве шаблонов могут выступать следующие типы файлов: шаблоны и документы Word (расширения DOC, DOCX, DOCM, DOT, DOTX, DOTM) шаблоны и книги Excel (расширения XLS, XLSX, XLSM, XLSB, XLT, XLTX, XLTM)...

Макрос предназначен для программного создания документов Word на основе шаблона (без использования функции слияния в Word) В прикреплённом к статье архиве находятся 2 файла: шаблон договора в формате Microsoft Word (расширение .dot) файл Excel с макросом Настройки макроса задаются в коде: Const ИмяФайлаШаблона = "шаблон.dot" Const КоличествоОбрабатываемыхСтолбцов = 8...

Данный макрос позволяет упростить процедуру сохранения активного листа в книге Excel в отдельный файл. Для использования этого макроса на любом листе в книге Excel создайте кнопку, и назначьте ей макрос СохранитьЛистВФайл. При запуске макроса (нажатии кнопки) будет выведено диалоговое окно выбора имени для сохраняемого файла, после чего текущий лист будет сохранён под заданным именем в...

Надстройка позволяет экспортировать все изображения с листа Excel в графические файлы. Доступен выбор типа создаваемых файлов (поддерживаются форматы JPG, GIF и PNG) Кроме того, можно указать имя папки, в которую будут помещены созданные файлы (эта папка будет создана автоматически в том же каталоге, где расположен обрабатываемая книга Excel) Если нужно сохранять картинки под именами из...

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

Можно ли прикрепить (вложить) произвольные файлы в обычную книгу Excel? А потом извлечь эти файлы в заданную папку, и работать с ними? Казалось бы, Excel такого не позволяет. (а если и позволяет, то извлечь вложенные файлы без из запуска - весьма проблематично) Но, при помощи макросов, можно реализовать что угодно (и сохранение\извлечение файлов в том числе) Теперь прикрепить к книге Excel...

К примеру, есть у вас несколько десятков (или сотен) текстовых файлов с подобным содержимым: (количество файлов, и количество строк данных в каждом файле не ограничено) 1c04;1J0-698-151-G;1 комплект тормозных накладок;1J0698151G;1J0698151G;5;1 1c04;1H0698151A;Тормозные колодки;1H0698151A;1H0698151A;1;1 1c04;1K0-698-151-B;Тормозные колодки;1K0698151B;1K0698151B;2;1 А надо из всего этого...

Программа предназначена для автоматизации формирования договоров комиссии и купли автотранспортного средства. В качестве исходных данных выступают: таблица Excel с реквизитами создаваемых документов папка с шаблонами договоров (в формате dot) В исходной таблице Excel занесены все необходимые исходные данные для заполнения бланков договоров, а также, при помощи пользовательских формул (UDF),...

Программа предназначена для работы с заказами, оформляемыми менеджерами на выставках. Основные функции программы: создание (заполнение) новых заказов редактирование существующих заказов объединение нескольких заказов в один формирование заявки на продукцию на основании данных их сформированных заказов Для каждого заказа предусмотрен выбор клиента из базы данных (если клиент...

Программный комплекс, предназначенный для автоматизации учёта и администрирования сети связи телефонной или телекоммуникационной компании. Программа позволяет хранить и редактировать базу данных объектов (в виде файлов Excel), просматривать существующие трассы и формировать новые. Особенность программы - возможность учёта и администрирования узлов связи с нестандартными...

Данный макрос позволяет быстро (одним нажатием кнопки) пересохранить текущий файл Excel в другом формате. Например, вы работаете с книгой Excel в формате Excel 97-2003 (расширение XLS), и вам понадобилось преобразовать этот файл в формат «двоичная книга Excel» (расширение XLSB) Для чего это нужно? К примеру, файлы в формате XLSB занимают намного меньше места на диске, и не...

Функция предназначена для разбивки текстового файла на несколько файлов меньшего размера - в каждом из которых будет не более заданнного количества строк Разделитель строк (обычно это перевод строки - константа vbNewLine) задаётся в качестве параметра функции Delimiter$ Создаваемые файлы получают имена вида filename(1).txt, filename(2).txt и т.д. Если задан параметр функции...

Макрос для архивации текущей (или активной) книги Excel средствами Windows (без использования сторонних программ-архиваторов) Во вложении - файл, при запуске которого автоматически срабатывает такой макрос При открытии этого файла, если включены макросы, в папке My Program Backups будет сохранена копия книги в формате ZIP (архив) Папка, если таковая не существует, будет автоматически создана...

Программа предназначена для формирования прайс-листов на ноутбуки с соответствии с требованиями интернет-каталога Onliner.by Основные функции программы: (учитываются цены фирм-конкурентов, цены onliner.by и надбавка фирмы) загрузка каталога ноутбуков (названия, характеристики, цены) с сайта onliner.by в файл Excel, и обновление этого каталога назначение соответствий моделей...

Данная функция формирует (создаёт) новую книгу Excel с одним листом (на основании шаблона - листа sh_template), после чего сохраняет новый файл по пути NewFilename$ Если путь не указан, сохранения нового файла не происходит. Function NewWorksheet(ByRef sh_template As Worksheet, Optional ByVal NewFilename$) As Worksheet Application.ScreenUpdating = False: On Error Resume Next: Err.Clear...

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

Программа предназначена для формирования заданий на производство. Исходными данными выступают таблицы Excel и файлы XML. При конвертации таблиц происходит обработка данных и перестановка столбцов. При запуске программа формирует панель инструментов с 6 кнопками - для обработки файлов различной структуры.

Программа представляет собой калькулятор стоимости быстровозводимых зданий, с возможностью создания прайс-листа для разных значений длины, ширины и высоты здания. В качестве исходных данных для создаваемого прайс-листа, задаются начальные и конечные значения таких параметров, как ширина, длина и высота здания, а также шаг изменения каждого из параметров: Для каждого значения из...

Программа предназначена для обработки отчётов управления по сделкам с ценными бумагами Основные функции программы: Создание новых отчётов управления (за следующий квартал) на основании текущих отчётов Внесение изменений и дополнений в существующие отчёты Формирование сводной таблицы по вкладам для оценки роста, а также коэффициентов ликвидности и версификации вкладов Обработка...

Программа предназначена для создания отчётов по детализации телефонных звонков (междугородная и международная связь), последующей упаковки созданных детализаций в ZIP архив, и автоматизированной рассылки сформированных писем абонентам. При запуске программа ищет в заданной папке исходные файлы с детализацией (упакованные в ZIP файлы DBF), и на основании из этих файлов формирует (по шаблону, с...

В некоторых случаях, при запуске файла Excel с макросами (к примеру, надстройки Excel), для обеспечения работы макросов требуется, чтобы был полный доступ к файлу (а не "только чтение"), или же файл был сохранён в заданной папке. Полный доступ к файлу необходим, например, для работы автоматического обновления надстройки, а постоянный путь может потребоваться, если вы хотите...

Программа формирует выгрузку в CSV для выделенных строк таблицы Excel Есть возможность одним нажатием выделить все строки в таблице (или снять выделение со всех строк) Реализована возможность разбиения итогового файла CSV на несколько, с заданным максимальным количеством строк. (создаваемые файлы автоматически нумеруются)

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

Клавиша: Ctrl + T Макрос: Создание Текстовых Файлов Клавиша: Ctrl + 4 Макрос: Окраска Объединённых Ячеек Клавиша: Ctrl + 5 Макрос: Окраска Всех Объединённых Ячеек Клавиша: Ctrl + G Макрос: Объединение Значений Из Ячеек Клавиша: Ctrl + Shift + G Макрос: Разъединение Значений Из Ячеек Клавиша: Ctrl + Shift + D Макрос: Поиск Дубликатов В Книге Клавиша: Ctrl + Shift + O Макрос:...

Надстройка SplitFile позволяет создать из одного файла Excel несколько файлов, с заданным ограничением по количеству строк. Обычно разбивка файла (формата XLSX или CSV) требуется для загрузки данных в интернет-магазин, когда в загружаемом файле много строк (десятки тысяч), а движок интернет магазина не поддерживает большие файлы (или зависает из-за большого объема данных) В настройках программы...

Функция предназначена для сохранения двумерного массива в файл формата XLS Sub SaveArray(ByVal Arr, ByVal ColumnNames, ByVal DocName$) ' Получает двумерный массив Arr с данными, и массив заголовков столбцов ColumnNames. ' Создаёт новый файл в подпапке СФОРМИРОВАННЫЕ ДОКУМЕНТЫ с именем DocName$ On Error Resume Next ' создаём подпапку (там же, где текущий файл Excel)...

excelvba.ru

Как создать и добавить надстройку в Excel с кодом VBA

Надстройки Excel – это прекрасная альтернатива создания макросов доступных для использования любых других файлов рабочих книг. Если Вам понравиться создавать свои надстройки и вы войдете во вкус, то это полезное и интересное занятие может еще для вас приносить неплохой доход. Надстройки можно публиковать и продавать в магазине Office Store. В данном примере мы покажем, как создать свою достройку с макросом, написанным на коде самого простого и весьма востребованного языка программирования VBA (Visual Basic for Applications).

Как сделать и установить надстройку в Excel

Чтобы создать, добавить и включить свою надстройку с макросом, следует:

Создайте новую рабочую книгу: «ФАЙЛ»-«Создать»-«Пустая книга». Или нажмите комбинацию горячих клавиш CTRL+N.
Откройте редактор макросов: «РАЗРАБОТЧИК»-«Код»-«Visual Basic».
Вставьте новый модуль выбрав инструмент: «Insert»-«Module».
В окне модуля введите свой код макроса. Возьмем простейший пример макроса:
Закройте окно редактора макросов и выберите инструмент: «ФАЙЛ»-«Сохранить как» (CTRL+S). В поле «Имя файла:» введите название для своей тестовой программы. А из выпадающего списка «Тип файла:» выберите значение «Надстройка Excel 97-2003» (*.xla). Автоматически откроеться папка для установки надстроек: C:\Documents and Settings\User_Name \AppData\Roaming\Microsoft\AddIns. И нажмите на кнопку «Сохранить».
Перед тем как установить надстройку в Excel, закройте все открытые рабочие книги снова запустите программу Excel.
Выберите инструмент: «ФАЙЛ»-«Параметры»-«Надстройки». Внизу из выпадающего списка «Управление:» укажите на опцию «Надстройки Excel» и нажмите на кнопку «Перейти».
В появившемся диалоговом окне «Надстройки» нажмите на кнопку «Обзор», а после найдите и найдите свое название, на против него поставьте галочки и нажмите на кнопку «Ок». Если вы не находите названия нажмите на кнопку «Обзор», чтобы указать путь к вашему файлу с надстройкой.

Надстройка VBA готова! Теперь во всех открытых рабочих книгах можно будет воспользоваться макросами из вашего *.xla файла. Чтобы убедиться в этом снова откройте редактор Visual Basic (ALT+F11).

Как видно ее теперь всегда можно найти в списке проектов и использовать все ее макросы в любых других файлах.

Как удалить надстройку в Excel

Чтобы отключить вашу надстройку снова откройте окно «ФАЙЛ»-«Параметры»-«Надстройки»-«Перейти» и снимите соответственную галочку в появившемся диалоговом окне. Для полного удаления надстройки придется удалить ее файл *.xla из папки C:\Documents and Settings\User_Name \AppData\Roaming\Microsoft\AddIns.

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

Внимание! В данном примере мы использовали формат рабочей книги для сохранения файла в формате «Надстройка 97-2003». Это позволяет использовать ее в разных версиях Excel. Например, файлы, сохраненные в формате *.xlam не может быть использована в версии 2007 и старше. Поэтому лучше воспользоваться старым форматом файлов надстройке *.xla.

Читайте также: скачать VBA код программы надстройки сумма прописью с копейками на русском, украинском и английском языке. Или перевод числа в текст средствами Excel.

Примечание. Если вы хотите защитить паролем доступ к своим исходным кодам макросов, тогда выберите инструмент в редакторе Visual Basic: «Tools»-«VBAProject Properties». На закладке «Protection» в поле ввода «Password:» введите пароль для защиты доступу к макросам проекта рабочей книги. В поле ввода «Confirm password:» введите пароль повторено и нажмите на кнопку ОК.

exceltable.com

Создать PDF-файл и отправить E-mail из кода VBA MS Excel онлайн

У меня есть файл, который сохраняет вывод как Excel для чтения. Я хочу также сохранить файл в формате PDF, а затем отправить по электронной почте. Любая помощь высоко ценится!

Текущий код VBA:

Sub SaveFile() 'Recalc Sheets prior to saving down a = MsgBox("Do you want to Save the Performance Reports?", vbOKCancel) If a = 2 Then Exit Sub Dim SaveSheets As Variant Dim strFilename As String Dim sheetListRange As Range Dim sheetName As Variant Dim wksheet As Variant Dim wkbSrc As Workbook Dim wkbNew As Workbook Dim wksNew As Worksheet Dim wksSrc As Worksheet Dim i As Integer 'On Error GoTo ErrorHandler strFilename = Worksheets("Control").Range("SavePath").Value & "Ergonomie_Consultants_Performance_" & Format$(Now(), "YYYYMMDD") & ".xls" Set sheetListRange = Worksheets("Control").Range("SaveList") Set wkbSrc = ActiveWorkbook Set wkbNew = Workbooks.Add i = 0 For Each sheetName In sheetListRange If sheetName = "" Then GoTo NEXT_SHEET For Each wksheet In wkbSrc.Sheets If wksheet.Name = sheetName Then i = i + 1 wksheet.Copy Before:=wkbNew.Sheets(i) Set wksNew = ActiveSheet With wksNew .Cells.Select .Cells.Copy .Cells(1, 1).PasteSpecial Paste:=xlPasteValues .Cells(1, 1).PasteSpecial Paste:=xlPasteFormats End With ActiveWindow.Zoom = 75 GoTo NEXT_SHEET End If Next wksheet NEXT_SHEET: Next sheetName Application.DisplayAlerts = False 'dont need the default new sheets created by created a new workbook wkbNew.Worksheets("Sheet1").Delete 'wkbNew.Worksheets("Sheet2").Delete 'wkbNew.Worksheets("Sheet3").Delete 'ActiveWorkbook.SaveAs Filename:=strFilename, FileFormat:=xlsm ActiveWorkbook.SaveAs Filename:=strFilename, FileFormat:=xlNormal ActiveWorkbook.Close Application.DisplayAlerts = True Exit Sub 'RememberErrLine = Erl() 'PROC_ERR: '140 MsgBox "Value: " & dblRnd & vbCrLf & _ ' "Error Line: " & Erl & vbCrLf & _ ' "Error: (" & Err.Number & ") " & Err.Description, vbCritical ErrorHandler: 'If there is an unknown runtime error give the user the error number and associated description '(Description is already set if the erorr is G_LNG_CRITICAL_ERROR) If Err.Number <> CRITICAL_ERROR Then Err.Description = "Run-time error " & Err.Number & ": " & Err.Description Err.Description = "Error saving worksheet as file: " & Err.Description Err.Source = "Error saving worksheet as file: " & Err.Source 'Raise the error up to the error handler above Err.Raise Number:=CRITICAL_ERROR End Sub

Solutions Collecting From Web of "Создать PDF-файл и отправить E-mail из кода VBA"

excel.bilee.com

vba - VBA - создание файла Excel из Access (QueryTable)

У меня есть проект, который в основном состоит в том, чтобы генерировать Excel (Report), начиная с нажатия кнопки в Access, используя VBA.

Содержимое этого отчета является результатом хранимой процедуры SQL Server Database.

строка ошибки:

With MeuExcel.Worksheets(4) .QueryTables.Add connection:=rs, Destination:=.Range("A2") End With

Я получаю:

invalid procedure call or argument (erro '5')

Полный код (отредактирован с помощью рекомендаций пользователя Remou):

Sub GeraPlanilhaDT() Dim MeuExcel As New Excel.Application Dim wb As New Excel.Workbook Set MeuExcel = CreateObject("Excel.Application") MeuExcel.Workbooks.Add MeuExcel.Visible = True Dim strNomeServidor, strBaseDados, strProvider, strConeccao, strStoredProcedure As String strNomeServidor = "m98\DES;" strBaseDados = "SGLD_POC;" strProvider = "SQLOLEDB.1;" strStoredProcedure = "SP_ParametrosLeads_DT" strConeccao = "Provider=" & strProvider & "Integrated Security=SSPI;Persist Security Info=True;Data Source=" & strNomeServidor & "Initial Catalog=" & strBaseDados Dim cnt As New ADODB.connection Dim cmd As New ADODB.command Dim rs As New ADODB.recordset Dim prm As New ADODB.parameter cnt.Open strConeccao cmd.ActiveConnection = cnt cmd.CommandType = adCmdStoredProc cmd.CommandText = strStoredProcedure cmd.CommandTimeout = 0 Set prm = cmd.CreateParameter("DT", adInteger, adParamInput) cmd.Parameters.Append prm cmd.Parameters("DT").Value = InputBox("Digite o Código DT", "Código do Distribuidor") Set rs = cmd.Execute() Dim nomeWorksheetPrincipal As String nomeWorksheetPrincipal = "Principal" Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = nomeWorksheetPrincipal With MeuExcel.Worksheets(4) .QueryTables.Add connection:=rs, Destination:=.Range("A2") End With cnt.Close Set rs = Nothing Set cmd = Nothing Set strNomeServidor = Nothing Set strBaseDados = Nothing Set strProvider = Nothing If (ActiveSheet.UsedRange.Rows.Count > 1) Then FormataDadosTabela Else MsgBox ("Não foi encontrado nenhum Distribuidor com esse DT") End If End Sub

Странно, что код работает при запуске в Excel, но не работает в Access

задан Predoff 03 янв. '12 в 20:47 источник поделиться

qaru.site

vba - Оптимизировать печать VBA Excel - создать PDF файл?

На данный момент я печатаю папку, полную файлов xlsx. Я хочу оптимизировать и ускорить процесс - для отправки 20 страниц на принтер требуется около 40 секунд, т.е. одна страница из 20 разных файлов.

Могу ли я отправить каждую из этих страниц в файл PDF сначала, а затем отправить этот файл PDF один раз на принтер (а затем я могу печатать на обеих сторонах страницы - это было бы потрясающе)

Я бы предпочел сделать это, как когда приложение будет завершено, оно будет печатать до 300 страниц одним ударом. Поэтому я думаю, вы можете увидеть преимущества использования обеих сторон и только отправить один файл pdf на принтер.

Любая помощь будет потрясающей,

Текущий код:

Sub Print_Long_Sections(ByVal LongFolderPath As String) ' #################################################################################### ' # INTRO '------------------------------------------------------------------------------------- ' Purpose ' This procedure assist the user to print all the long section files in the ' folder that they saved the files to. This saves the need to open all the files ' ' ' ' #################################################################################### ' # DECLAIRATIONS '------------------------------------------------------------------------------------- ' OBJECTS Dim LongFolder As Folder Dim LongFile As File Dim OpenLong As Workbook Dim FileSystemObj As New FileSystemObject '------------------------------------------------------------------------------------- ' VARIABLES Dim iLoopVar As Long Dim DefaultPrinter As String ' #################################################################################### ' # PROCEDURE CODE '------------------------------------------------------------------------------------- ' optimise speed Application.ScreenUpdating = False '------------------------------------------------------------------------------------- ' Select the Printer DefaultPrinter = Application.ActivePrinter MsgBox "Select your printer" Application.Dialogs(xlDialogPrinterSetup).Show '------------------------------------------------------------------------------------- ' Print the Files in the Folder: Set LongFolder = FileSystemObj.GetFolder(LongFolderPath) '// set the folder object to the user specified folder For Each LongFile In LongFolder.Files '// loop through all the files in the folder If FileSystemObj.GetExtensionName(LongFile.Path) = "xlsx" Then '// check file is an xlsx file, If InStr(1, LongFile.Name, "PipeLongSec") > 0 Then '// check file is a long section Set OpenLong = Workbooks.Open(LongFile.Path) '// open the file OpenLong.Sheets(1).PrintOut '// send file to default printer OpenLong.Close '// close the file End If End If Next '------------------------------------------------------------------------------------- ' Re-Set Printer to Previous Settings Application.ActivePrinter = DefaultPrinter '------------------------------------------------------------------------------------- ' END PROCEDURE Application.ScreenUpdating = True Set OpenLong = Nothing Set LongFolder = Nothing Set LongFile = Nothing Set FileSystemObj = Nothing End Sub

С Уважением,

Джо

источник поделиться

qaru.site

использование Excel 2010 VBA создать текстовый документ, состоящий текст из нескольких файлов слов

Как сказал KazJaw в качестве промежуточного пользователя VBA, вы должны иметь возможность создавать пользовательскую форму и связанный с ней код, который позволяет вашим пользователям выбирать документ Word, как вы описали. Как только вы начнете работать с документом Word, все будет немного отличаться от кодирования для Excel.

Позвольте мне поделиться мало я знаю об этом:

Во-первых, убедитесь, что вы активировали библиотеку объектов Word: В меню Сервис выберите команду Ссылки. В списке доступных ссылок найдите и выберите соответствующую библиотеку объектов Microsoft Word

Как я понимаю, поздняя привязка просто означает объявление типа объекта при назначении значения. Я понятия не имею, поможет ли это решить проблему «Ошибка доступа к системному реестру». Я использовал позднее связывание, когда я звоню документов Word сначала определить переменную в качестве родового объекта:

Dim wdApp As Object Dim wd As Object

Тогда определяющий объект (ы), который я создал:

On Error Resume Next Set wdApp = GetObject(, "Word.Application") 'establishing the word application If Err.Number <> 0 Then Set wdApp = CreateObject("Word.Application") End If On Error GoTo 0 Set wd = wdApp.Documents.Open("C:\YourFilePath") 'establishing a file to use

После того, как вы сделали это , вы можете начать манипулировать Word с помощью доступных вам команд, все из которых вы сможете найти в другом месте в Интернете или использовать подсказки компилятора (например, введите Word.Application.ActiveDocument. и вы увидите список доступных функций для управления этот документ). Вот несколько, с которыми я использовал ранее определенную переменную wd для обозначения конкретного документа:

wd.Activate 'activate the word doc wd.PrintOut 'printout the word doc wd.FormFields("BundleNumber1").Result = sBundleNumber 'fill in a pre-established form field with data stored in the variable 'sBundleNumber' wd.Close 'close the word doc

Если вы выбираете все содержание документа, я думаю, что должно быть довольно Пролив вперед (что-то вроде Word.Application.ActiveDocument.SelectAllEditableRanges, но если вам нужно выбрать подраздел документа, вы должны знать, что диапазоны могут быть определены в Word во многом так же, как они определены в Excel, но ребра не такие аккуратные, как ячейки в Excel. Я считаю, что они определены параграфами и перерывами, но вам нужно будет исследовать, как это делается: я никогда не делал этого.

Надеюсь, это поможет вам создать код, (в случае необходимости).

stackoverrun.com

excel - VBA - как создать папки и переместить туда файлы?

Обидевшись на ваши ответы, и посидев немного с VBA все таки написал скрипт, хоть и вышел за пределы сроков. Надеюсь вам пригодится, так что я выложу его сюда

Sub Кнопка1_Щелчок() Dim i As Long Dim ActWB As Workbook Dim avInp(), fl As Object Dim Kol_pid, Pid, kol1 As Integer Dim Stolbec, StrokaOtsch As Integer Dim NameFile() As String Dim NewFoldPth, OldFoldPth, FoldPth, NewFolder1, NewFolder As String Dim ki, counter As Long Dim Fiyli() As String Dim Stolbec1 As String Dim iSheet As Integer ' Индекс листа Dim sFPName As String ' Имя последней папки перед нумерацией Set FSO = CreateObject("Scripting.FileSystemObject") Stolbec1 = Application.InputBox("Укажите номер столбца, в котором находятся наименования файлов", "Номер столбца", "3") Kol_pid = Application.InputBox("Укажите количество файлов в папке", "Номер папки", "3") StrokaOtsch = Application.InputBox("Укажите номер строки начала данных", "Номер строки", "3") StolbecOut = Application.InputBox("Укажите номер столбца куда писать пути", _ "Номер столбца", "3") Stolbec = CInt(Stolbec1) StrokaOtsch = CInt(StrokaOtsch) StolbecOut = CInt(StolbecOut) Application.ScreenUpdating = False i1_n = Cells(Rows.Count, Stolbec).End(xlUp).Row Set ActWB = ActiveWorkbook iSheet = ActiveSheet.Index ' NewFolder = Application.InputBox("Укажите имя папки, в которую необходимо перенести файлы", "Имя новой папки", _ ' "Файлы из списка") ' StrokaOtsch = Application.InputBox("Укажите номер строки, в которой находится шапка таблицы", _ ' "Номер строки", "1") ' NewFolder = "fileout" ' counter = 3 ' StrokaOtsch = "1" Pid = 1 With Application.FileDialog(msoFileDialogFolderPicker) .Title = "Папка Откуда копировать файлы" .ButtonName = "Select": .AllowMultiSelect = False If .Show Then FoldPth = .SelectedItems(1) Else Exit Sub End With With Application.FileDialog(msoFileDialogFolderPicker) .Title = "Папка Куда копировать файлы" .ButtonName = "Select": .AllowMultiSelect = False If .Show Then NewFolderPath = .SelectedItems(1) Else Exit Sub 'MsgBox (.SelectedItems(1)) End With 'NewFolderPath = NewFolderPath & "\" Time_1 = Timer If Right(NewFolder, 1) <> "\" Then NewFolder = NewFolder & "\" If Right(FoldPth, 1) <> "\" Then FoldPth = FoldPth & "\" bbb = Split(NewFolderPath, "\") sFPName = bbb(UBound(bbb)) ReDim NameFile(i1_n - StrokaOtsch) 'For i1 = 1 To i1_n - StrokaOtsch + 1 ' If Cells(StrokaOtsch + i1 - 1, Stolbec) <> "" Then ' n = n + 1 ' NameFile(n) = Cells(StrokaOtsch + i1 - 1, Stolbec) ' End If ' Next i1 ReDim Preserve NameFile(n) Set FSO = CreateObject("Scripting.FileSystemObject") With FSO If Not .FolderExists(NewFolderPath & "\" & Pid & "\") Then .CreateFolder NewFolderPath & "\" & Pid & "\" 'создание нового каталога куда копировать каталога With .GetFolder(FoldPth) ' If .Files.Count = 0 Then MsgBox "Файлов в указанном пути не найдено", 48: Exit Sub 'проверка наличия файлов откуда происходит копирование ' ReDim Fiyly(.Files.Count) ' For Each fl In .Files ' ki = ki + 1 ' Fiyly(ki) = fl.Name ' MsgBox (Fiyly(ki)) Заполнение массива именами файлов, находящихся в каталоге которые надо копировать ' Next fl kol1 = 1 For i1 = StrokaOtsch To i1_n ' For i = 1 To UBound(Fiyly) If Cells(i1, Stolbec) <> "" Then ' MsgBox (Cells(i1, Stolbec)) ' NameFile(i1) = Cells(i1, Stolbec) ' If Fiyly(i) = NameFile(i1) Then If kol1 = Kol_pid + 1 Then Pid = Pid + 1 With FSO If Not .FolderExists(NewFolderPath & "\" & Pid & "\") Then .CreateFolder NewFolderPath & "\" & Pid & "\" End With kol1 = 1 End If ' MsgBox (FoldPth & NameFile(i1) & "Новая куда" & NewFolderPath) If FSO.FileExists(FoldPth & Cells(i1, Stolbec)) Then Kol = Kol + 1 kol1 = kol1 + 1 FSO.MoveFile FoldPth & Cells(i1, Stolbec), NewFolderPath & "\" & Pid & "\" ActWB.Sheets(iSheet).Cells(i1, StolbecOut).Value = sFPName & "\" & Pid & "\" & Cells(i1, Stolbec) End If ' End If ' Next i End If Next i1 End With End With time_ = Time_1 - Timer Time_delta = Format(time_ / 24 / 60 / 60, "hh\ч mm\м ss\с") Application.ScreenUpdating = True MsgBox ("Выполнено за " & Time_delta & Chr(13) & "Количество перемещённых файлов :" & Kol) End Sub

ru.stackoverflow.com