Как я могу создать новый файл Excel/Workbook в VBA, не открывая его автоматически? Создать файл vba excel

Создание и запись в текстовый файл с использованием макроса excel и VBA

Вы можете объединить данные в массив и затем преобразовать его в текст.

Sub ExcelToTxt() 'Declaring variables Dim i As Long, j As Integer Dim n As Long, k As Long Dim destgroup As String Dim FName As String Dim vDB, vR(1 To 6), vJoin(), vResult() Dim sJoin As String, sResult As String Dim s As Long 'Activate Sheet1 Sheet1.Activate 'Find the last row that contains data With Sheet1 vDB = .Range("a1").CurrentRegion '<~~ get data to array from your data range n = UBound(vDB, 1) 'size of array (row of 2 dimension array) End With 'Create txt file FName = Application.GetSaveAsFilename("", "txt file (*.txt), *.txt") For i = 2 To n '<~~loop destgroup = vDB(i, 2) '<~~ second column If destgroup = "trex_15hz" Or destgroup = "trex_10hz" Or destgroup = "trex_5hz" Then vR(1) = "; ### LABEL DEFINITION ###" '<~~ text 1st line s = Val(Replace(vDB(i, 3), "label", "")) vR(2) = "EQ_LABEL_DEF,02," & Format(s, "000") vR(3) = "UDB_LABEL," & Chr(34) & vDB(i, 4) & Chr(34) '<~~ 2nd line ReDim vJoin(4 To 7) vJoin(4) = Chr(34) & vDB(i, 4) & Chr(34) For j = 5 To 7 vJoin(j) = vDB(i, j) Next j sJoin = Join(vJoin, ",") vR(4) = "STD_SUB_LABE," & sJoin '<~~ 3th line ReDim vJoin(8 To 12) vJoin(8) = Chr(34) & UCase(vDB(i, 8)) & Chr(34) vJoin(9) = Chr(34) & vDB(i, 9) & Chr(34) vJoin(10) = Format(vDB(i, 10), "#.000000000") For j = 11 To 12 vJoin(j) = vDB(i, j) Next j sJoin = Join(vJoin, ",") vR(5) = "STD_SUB_LABE," & sJoin '<~~ 4the line vR(6) = "END_EQ_LABEL_DEF" '<~~ 5th line k = k + 1 ReDim Preserve vResult(1 To k) vResult(k) = Join(vR, vbCrLf) '<~~ 5 line in array vR and get to array vResult with join method End If Next i sResult = "EQUIPMENT_ID_DEF,02,0x1," & Chr(34) & "trex" & Chr(34) '<~~ text file first line sResult = sResult & vbCrLf & Join(vResult, vbCrLf) '<~~ combine 1th and other line ConvertText FName, sResult '<~~ sub presedure End Sub Sub ConvertText(myfile As String, strTxt As String) Dim objStream Set objStream = CreateObject("ADODB.Stream") With objStream '.Charset = "utf-8" .Open .WriteText strTxt .SaveToFile myfile, 2 .Close End With Set objStream = Nothing End Sub

stackoverrun.com

Macro VBA Excel создать дату файла XML

с макросом VBA в Excel Мне нужно преобразовать дату на 1 лист в файл excel. Для этого я уже создал скрипт, но у меня есть проблема, чтобы правильно генерировать дату в XML. Мне нужна первая строка заголовка, а затем формула считывает все строки с данными.

Sub createXML() Sheets("Sheet1").Select FullPath = baseDirectory & projectName & "\xmlBatch\inputTest.xml" Set objStream = CreateObject("ADODB.Stream") objStream.Charset = "iso-8859-1" objStream.Open objStream.WriteText ("<?xml version='1.0' encoding='UTF-8'?>" & vbLf) objStream.WriteText ("<y:input xmlns:y='http://www.test.com/engine/3'>" & vbLf) objStream.WriteText (" <y:datas>" & vbLf) objStream.WriteText (" <y:instance yid='theGeneralData'>" & vbLf) objStream.WriteText ("" & vbLf) objStream.WriteText ("<language yid='LANG_en' />" & vbLf) objStream.WriteText ("<client yclass='Client'>" & vbLf) objStream.WriteText (" <firstName>" & Cells(1, 1).Text & "</firstName>" & vbLf) objStream.WriteText (" <lastName>" & Cells(1, 2).Text & "</lastName>" & vbLf) objStream.WriteText (" <age>" & Cells(1, 3).Text & "</age>" & vbLf) objStream.WriteText (" <civility yid='" & toYID(Cells(1, 4).Text) & "' />" & vbLf) objStream.WriteText ("</client>" & vbLf) objStream.WriteText ("" & vbLf) objStream.WriteText (" </y:instance>" & vbLf) objStream.WriteText (" </y:datas>" & vbLf) objStream.WriteText ("</y:input>" & vbLf) objStream.SaveToFile FullPath, 2 objStream.Close End Sub

данные Excel теперь в этом формате:

enter image description here

Но мой выход для теперь это:

Нам нужно иметь этот результат:

> <?xml version='1.0' encoding='UTF-8'?> <y:input xmlns:y='http://www.test.com/engine/3'> <y:datas> <y:instance yid='theGeneralData'> <language yid='LANG_en' /> <client yclass='Client'> <firstName>1</firstName> <lastName>1</lastName> <age>1</age> <civility yid='CIVILITY' /> </client> <client yclass='Client'> <firstName>2</firstName> <lastName>2</lastName> <age>2</age> <civility yid='CIVILITY' /> </client> <client yclass='Client'> <firstName>3</firstName> <lastName>3</lastName> <age>3</age> <civility yid='CIVILITY' /> </client> </y:instance> </y:datas> </y:input>

stackoverrun.com

Создайте цикл, чтобы открыть несколько файлов и скопировать данные в главный файл в VBA excel

У меня есть несколько файлов с данными, которые необходимо перенести в один главный файл со всеми данными в одну строку.

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

я смог найти это «Loop всех Excel файлов в папка "с сайта www.TheSpreadsheetGuru.com Код работает отлично, он откроет каждый файл отдельно в папке, а затем закроет его, а затем откроет следующий файл и закроет его, пока он не пройдет через каждый файл в этой папке ,

Однако я хотел бы вставить цикл цикла «копировать и вставлять данные» в цикл. Итак, что должно произойти, код откроет «File1» в папке, а затем скопирует и вставляет данные в «Мастер-файл» в ячейке A4. Затем он закроет «File1», а затем откройте «File2» и скопируйте данные в «Мастер-файл» в ячейке A5, а затем закройте «File2». Он повторит это, пока все файлы в папке не будут открыты/закрыты.

Это код, который у меня есть прямо сейчас, но я не могу заставить код для копирования и вставки правильно работать. Мне сложно определить, как установить цикл, где код будет знать, в каком файле он находится сейчас, и установить счетчик для ячейки основного файла, в который он вставляется.

Sub LLoopAllExcelFilesInFolder() 'PURPOSE: To loop through all Excel files in a user specified folder and perform a set task on them 'SOURCE: www.TheSpreadsheetGuru.com Dim wb As Workbook Dim myPath As String Dim myFile As String Dim myExtension As String Dim FldrPicker As FileDialog 'Optimize Macro Speed Application.ScreenUpdating = False Application.EnableEvents = False Application.Calculation = xlCalculationManual 'Retrieve Target Folder Path From User Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker) With FldrPicker .Title = "March" .AllowMultiSelect = False If .Show <> -1 Then GoTo NextCode myPath = .SelectedItems(1) & "\" End With 'In Case of Cancelhow NextCode: myPath = myPath If myPath = "" Then GoTo ResetSettings 'Target File Extension (must include wildcard "*") myExtension = "*.xlsx" 'Target Path with Ending Extention myFile = Dir(myPath & myExtension) 'Loop through each Excel file in folder Do While myFile <> "" 'Set variable equal to opened workbook Set wb = Workbooks.Open(Filename:=myPath & myFile) 'THIS IS MY COPY AND PASTE CODE (DOESN'T WORK) Dim row As Integer While row = 4 Workbooks("Filename:=myPath & myFile").Worksheets("Resin Log").cell("I5") = Workbooks("Workbook1.xlsm").Worksheets("Sheet1").Range("A" & row).Value Next row 'Save and Close Workbook wb.Close SaveChanges:=False 'Get next file name myFile = Dir Loop 'Message Box when tasks are completed MsgBox "Task Complete!" ResetSettings: 'Reset Macro Optimization Settings Application.EnableEvents = True Application.Calculation = xlCalculationAutomatic Application.ScreenUpdating = True End Sub

stackoverrun.com

Решение: Создание текстового файла - VBA

Необходимо создать текстовый файл: Создать типизированный файл, содержащий данные о фирмах: название фирмы, фамилия и инициалы владельца (одно поле), адрес (три поля: город, улица, дом), телефон. Переписать в текстовый файл и вывести в ячейки эл. таблицы данные о владельцах фирм, фамилия которых начинается с буквы М; Делаю по образу в методичке:Sub create_file_txt() Dim F As FIRMA Dim kol As Integer Dim str As String kol = InputBox("введите количество фирм") Open "C:\Users\Виталий\Desktop\VB и VBA\Задания\Екатерина Корожбина\firma" For Random As #1 Len = Len(F) For I = 1 To kol F.FIRMA = InputBox("Введите название фирмы:") F.fio = InputBox("Введите фамилию, имя, отчество:") F.city = InputBox("Введите город:") F.street = InputBox("Введите название улиц:") F.house = InputBox("Введите номер дома:") F.telefon = InputBox("Введите номер телефона:") 'str = CStr(F.FIRMA) + "," + CStr(F.fio) + "," + CStr(F.city) + "," + CStr(F.street) + "," + CStr(F.house) + "," + CStr(F.telefon) Put #1, I, F Next I Close #1 End SubНо выдает ошибку: Run-time error 59 Bad record lenght Пробовала формировать строкуSub create_file_txt() Dim F As FIRMA Dim kol As Integer Dim str As String kol = InputBox("ГўГўГҐГ¤ГЁГІГҐ ГЄГ®Г«ГЁГ·ГҐГ±ГІГўГ® ГґГЁГ°Г¬") Open "C:\Users\Г‚ГЁГІГ*Г«ГЁГ©\Desktop\VB ГЁ VBA\Г‡Г*Г¤Г*Г*ГЁГї\Г…ГЄГ*ГІГҐГ°ГЁГ*Г* ГЉГ®Г°Г®Г¦ГЎГЁГ*Г*\firma" For Random As #1 Len = Len(F) For I = 1 To kol F.FIRMA = InputBox("Введите название фирмы:") F.fio = InputBox("Введите фамилию, имя, отчество:") F.city = InputBox("Введите город:") F.street = InputBox("Введите название улиц:") F.house = InputBox("Введите номер дома:") F.telefon = InputBox("Введите номер телефона:") ' ***** str = CStr(F.FIRMA) + "," + CStr(F.fio) + "," + CStr(F.city) + "," + CStr(F.street) + "," + CStr(F.house) + "," + CStr(F.telefon) ' ***** Put #1, I, str ' Put #1, I, F.fio ', f.fio" ', f.city , f.street, f.house , f.telefon Next I Close #1 End Subтакже выдает ошибку: Run-time error 59 Bad record lenght Как мне записать данные в txt файл?

studassistent.ru

Создание текстовых файлов по таблице Excel

Макрос предназначен для создания текстовых файлов в кодировке UTF-8.

Исходными данными является таблица Excel из 12 столбцов.

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

Далее, для каждой строки таблицы, макрос формирует подпапку,используя в качестве её названия текст из 7-го столбца таблицы.

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

По окончании работы макроса, открывается папка, содержащая созданные текстовые файлы.

Пример макроса смотрите в прикреплённом файле.

Код макроса, создающего папки, подпапки, и текстовые файлы по данным из таблицы Excel:

Sub СозданиеТекстовыхФайлов() On Error Resume Next Dim cell As Range, ra As Range Set ra = Range([A2], Range("A" & Rows.Count).End(xlUp)).Resize(, 11) arr = ra.Value ' считываем данные в массив Set FSO = CreateObject("scripting.filesystemobject") ' создаём главную папку BaseFolder$ = ThisWorkbook.Path & "\Товар по группам\": MkDir BaseFolder$ ' перебираем все строки For i = LBound(arr) To UBound(arr) ' создаём папку для очередной строки (если папки ещё нет) Folder$ = BaseFolder$ & arr(i, 7) & "\" ' имя папки - в столбце G MkDir Folder$ ' формируем имя создаваемого текстового файла Filename$ = Folder$ & Trim(arr(i, 2)) & ".txt" ' создаём файл в кодировке Unicode Set ts = FSO.CreateTextFile(Filename$, True, True) ts.Write Trim(arr(i, 10)) ' данные в файл - из ячейки 10-го столбца ts.Close ' если текстовый файл нужен в другой кодировке ChangeFileCharset Filename$, "utf-8" Next i Set ts = Nothing: Set FSO = Nothing MsgBox "Файлы созданы, и помещены в папку" & vbNewLine & BaseFolder$, vbInformation, "Готово" ' открываем папку с файлами CreateObject("wscript.shell").Run "explorer.exe /e, """ & BaseFolder$ & """" End Sub ВложениеРазмерЗагрузкиПоследняя загрузка

prays.xls

38.5 КБ

233

27 недель 4 часа назад

excelvba.ru

vba - Как я могу создать новый файл Excel/Workbook в VBA, не открывая его автоматически?

Если вы планируете создавать 40 000 новых файлов, то .Add и .SaveAs замедлят ваш компьютер. И так как вы не хотите его открывать, я бы рекомендовал использовать ACE для этого. Вот краткий пример.

UNTESTED (на основе примера VB.Net ЗДЕСЬ)

Sub Sample() Dim cn As New ADODB.Connection, cmd As New ADODB.Command Dim FilePath As String Dim i As Long '~~> Folder to save the files FilePath = "C:\Temp\" For i = 1 To 40000 sFileName = FilePath & " File - " & i & ".xlsx" With cn .Provider = "Microsoft.ACE.OLEDB.12.0" .ConnectionString = "Data Source=" & sFileName & "Extended Properties=""Excel 12.0 Xml;HDR=YES;" .Open Set cmd = New ADODB.Command cmd.ActiveConnection = cn '~~> Command to create the table cmd.CommandText = "CREATE TABLE Sheet1 (Sno Int, " & _ "Employee_Name VARCHAR, " & _ "Company VARCHAR, " & _ "Date_Of_joining DATE, " & _ "Stipend DECIMAL, " & _ "Stocks_Held DECIMAL)" '~~> Adding Data cmd.CommandText = "INSERT INTO Sheet1 (Sno, Employee_Name, " & _ "Company,Date_Of_joining,Stipend,Stocks_Held) " & _ "values ('1', 'Siddharth Rout', 'Defining Horizons', " & _ "'20/7/2014','2000.75','0.01')" cmd.Execute .Close End With Next i End Sub

qaru.site

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

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:\windows\inf\*.*")

Debug.Print s

Do While s ""

s = Dir

Debug.Print s

Loop

End Sub

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

' Объявление API-функции для отображения стандартного окна _

просмотра папок

Declare Function SHBrowseForFolder Lib "shell32.dll" _

Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long

' Объявление API-функции для преобразования данных, возвращаемых _

функцией SHBrowseForFolder, в строку

Declare Function SHGetPathFromIDList Lib "shell32.dll" _

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

pszPath As String) As Long

' Структура используется функцией SHBrowseForFolder

Type BROWSEINFO

hwndOwner As Long ' Родительское окно (для диалога)

pidlRoot As Long ' Корневая папка для просмотра

strDisplayName As String

strTitle As String ' Заголовок окна

ulFlags As Long ' Флаги для окна

' Следующие три параметра в VBA не используются

lpfn As Long

lParam As Long

iImage As Long

End Type

Sub BrowseFolder()

Dim strPath As String ' Папка, список файлов которой выводится

Dim strFile As String

Dim intRow As Long ' Текущая строка таблицы

' Выбор папки

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 Long

Dim intLen As Integer

' Заполнение полей структуры BROWSEINFO

' Корневая папка - Рабочий стол

biBrowse.pidlRoot = 0&

' Заголовок окна

biBrowse.strTitle = "Выбор папки"

' Тип возвращаемой папки

biBrowse.ulFlags = &h2

' Вывод стандартного окна просмотра папок

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

topuch.ru