Excel VBA – создание нескольких файлов из данных в нескольких книгах. Vba excel создать файл excel
Создание каждой строки данных excel в xml-файлах с использованием макроса VBA
Я пытаюсь создать каждую строку (конкретные столбцы) данных Excel в xml-файлах (с тегами) с помощью VBA Macro. Я могу создавать файлы, но данные не заполняются в xml-файлы. Пожалуйста, помогите мне!!
Option Explicit Private Sub SaveAs_XML() On Error GoTo ErrHandle Dim doc As New MSXML2.DOMDocument60, xslDoc As New MSXML2.DOMDocument60, newDoc As New MSXML2.DOMDocument60 Dim root As IXMLDOMElement, dataNode As IXMLDOMElement, lastnameNode As IXMLDOMElement, AgeNode As IXMLDOMElement Dim dataNameAttrib As IXMLDOMAttribute, Attrib As IXMLDOMAttribute Dim nameAttrib As IXMLDOMAttribute, lastnameAttrib As IXMLDOMAttribute, AgeAttrib As IXMLDOMAttribute Dim i As Long Dim Folder As String Dim WS_Src As Worksheet, rng As Range, C As Range, d As Range Dim fs, f, ts, s Dim XDoc Folder = "\C:\New folder\" Set WS_Src = ThisWorkbook.Worksheets("data") Set rng = WS_Src.Range("B1", WS_Src.Range("B" & Rows.Count).End(xlUp)) For Each C In rng Set fs = CreateObject("Scripting.FileSystemObject") fs.CreateTextFile Folder & C.Value & ".xml" Set f = fs.GetFile(Folder & C.Value & ".xml") Next Set XDoc = CreateObject("MSXML2.DOMDocument") ' DECLARE XML DOC OBJECT ' Set root = doc.createElement("list") doc.appendChild root ' WRITE TO XML ' For i = 2 To Sheets(1).UsedRange.Rows.Count ' DATA NODE ' Set dataNode = doc.createElement("data") root.appendChild dataNode ' NAME ATTRIBUTE ' Set dataNameAttrib = doc.createAttribute("name") dataNameAttrib.Value = Range("B" & i) dataNode.setAttributeNode dataNameAttrib ' LASTNAME ATTRIBUTE ' Set lastnameAttrib = doc.createAttribute("lastname") lastnameAttrib.Value = Range("C" & i) lastnameNode.setAttributeNode lastnameAttrib ' AGE ATTRIBUTE ' Set AgeAttrib = doc.createAttribute("age") AgeAttrib.Value = Range("E" & i) AgeNode.setAttributeNode AgeAttrib Next i ' PRETTY PRINT RAW OUTPUT ' xslDoc.LoadXML "<?xml version=" & Chr(34) & "1.0" & Chr(34) & "?>" _ & "<xsl:stylesheet version=" & Chr(34) & "1.0" & Chr(34) _ & " xmlns:xsl=" & Chr(34) & "http://www.w3.org/1999/XSL/Transform" & Chr(34) & ">" _ & "<xsl:strip-space elements=" & Chr(34) & "*" & Chr(34) & " />" _ & "<xsl:output method=" & Chr(34) & "xml" & Chr(34) & " indent=" & Chr(34) & "yes" & Chr(34) & "" _ & " encoding=" & Chr(34) & "UTF-8" & Chr(34) & "/>" _ & " <xsl:template match=" & Chr(34) & "node() | @*" & Chr(34) & ">" _ & " <xsl:copy>" _ & " <xsl:apply-templates select=" & Chr(34) & "node() | @*" & Chr(34) & " />" _ & " </xsl:copy>" _ & " </xsl:template>" _ & "</xsl:stylesheet>" xslDoc.async = False MsgBox "Successfully exported Excel data to XML!", vbInformation Exit Sub ErrHandle: MsgBox Err.Number & " - " & Err.Description, vbCritical Exit Sub End SubОптимизировать печать VBA Excel – создать PDF-файл? MS Excel онлайн
Мне удалось создать то, что мне было нужно – способ поместить все мои созданные книги в то, что было легко распространять и печатать.
Код не печатает – вместо этого создает PDF:
Sub PDF_Long_Sections(ByVal LongFolderPath As String) ' #################################################################################### ' # INTRO '------------------------------------------------------------------------------------- ' Purpose ' This procedure assists the user to put all long sections from a folder into one ' PDF file. This makes it convieniet to share the long sections & print them. ' ' ' ' #################################################################################### ' # DECLAIRATIONS '------------------------------------------------------------------------------------- ' OBJECTS Dim LongFolder As Folder Dim LongFile As File Dim OpenLong As Workbook Dim ExportWB As Workbook Dim FileSystemObj As New FileSystemObject '------------------------------------------------------------------------------------- ' VARIABLES Dim iLoopVar As Long Dim DefaultPrinter As String Dim DefaultSheets As Variant Dim FirstSpace As Long Dim LastSpace As Long ' #################################################################################### ' # PROCEDURE CODE '------------------------------------------------------------------------------------- ' optimise speed Application.ScreenUpdating = False '------------------------------------------------------------------------------------- ' Print the Files in the Folder: Set LongFolder = FileSystemObj.GetFolder(LongFolderPath) '// set the folder object to the user specified folder DefaultSheets = Application.SheetsInNewWorkbook '// save default setting Application.SheetsInNewWorkbook = 1 '// create a one worksheet workbook Set ExportWB = Workbooks.Add Application.SheetsInNewWorkbook = DefaultSheets '// re-set application to default 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 FirstSpace = InStr(1, LongFile.Name, " ") '// record position of first space character LastSpace = InStr(FirstSpace + 1, LongFile.Name, " ") '// record position of last space character Set OpenLong = Workbooks.Open(LongFile.Path) '// open the file OpenLong.Sheets("Long Sections").Copy After:=ExportWB.Sheets(ExportWB.Sheets.Count) '// copy sheet into export workbook ExportWB.Sheets(ExportWB.Sheets.Count).Name = Mid(LongFile.Name, FirstSpace + 1, LastSpace - FirstSpace - 1) '// rename sheet we just moved to its pipe number OpenLong.Close '// close the file End If End If Next '------------------------------------------------------------------------------------- ' Delete the other worksheet Application.DisplayAlerts = False ExportWB.Sheets("Sheet1").Delete Application.DisplayAlerts = True '------------------------------------------------------------------------------------- ' Send Workbook to PDF - in save location ExportWB.ExportAsFixedFormat xlTypePDF, LongFolder.Path & "\" & LongFolder.Name & " " & Replace(Date, "/", "-") ExportWB.Close SaveChanges:=False '------------------------------------------------------------------------------------- ' 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Благодаря Сантошу, предполагающему, что у меня также есть метод Dir – к сожалению, оба метода занимают 23-24 секунды, когда я применяю таймер …
Sub DirPDF_Long_Sections(LongFolderPath As String) ' #################################################################################### ' # INTRO '------------------------------------------------------------------------------------- ' Purpose ' This procedure assists the user to put all long sections from a folder into one ' PDF file. This makes it convieniet to share the long sections & print them. ' ' THIS PROCEDURE USES DIR instead of FSO ' ' #################################################################################### ' # DECLAIRATIONS '------------------------------------------------------------------------------------- ' OBJECTS Dim LongFolder As String Dim LongFile As String Dim OpenLong As Workbook Dim ExportWB As Workbook 'Dim FileSystemObj As New FileSystemObject '------------------------------------------------------------------------------------- ' VARIABLES Dim count As Long Dim DefaultPrinter As String Dim DefaultSheets As Variant Dim FirstSpace As Long Dim LastSpace As Long Dim start_time, end_time ' #################################################################################### ' # PROCEDURE CODE '------------------------------------------------------------------------------------- ' optimise speed start_time = Now() Application.ScreenUpdating = False '------------------------------------------------------------------------------------- ' Print the Files in the Folder: DefaultSheets = Application.SheetsInNewWorkbook '// save default setting Application.SheetsInNewWorkbook = 1 '// create a one worksheet workbook Set ExportWB = Workbooks.Add Application.SheetsInNewWorkbook = DefaultSheets '// re-set application to default LongFile = Dir(LongFolderPath & "\*PipeLongSec*", vbNormal) While LongFile <> vbNullString '// loop through all the files in the folder '// check file is a long section FirstSpace = InStr(1, LongFile, " ") '// record position of first space character LastSpace = InStr(FirstSpace + 1, LongFile, " ") '// record position of last space character Set OpenLong = Workbooks.Open(LongFile) '// open the file OpenLong.Sheets("Long Sections").Copy After:=ExportWB.Sheets(ExportWB.Sheets.count) '// copy sheet into export workbook ExportWB.Sheets(ExportWB.Sheets.count).Name = Mid(LongFile, FirstSpace + 1, LastSpace - FirstSpace - 1) '// rename sheet we just moved to its pipe number OpenLong.Close '// close the file LongFile = Dir() Wend '------------------------------------------------------------------------------------- ' Delete the other worksheet Application.DisplayAlerts = False ExportWB.Sheets("Sheet1").Delete Application.DisplayAlerts = True '------------------------------------------------------------------------------------- ' Send Workbook to PDF - in save location ExportWB.ExportAsFixedFormat xlTypePDF, LongFolderPath & "\" & "LongSectionCollection " & Replace(Date, "/", "-") ExportWB.Close SaveChanges:=False '------------------------------------------------------------------------------------- ' Re-Set Printer to Previous Settings '##################################################################################### '# END PROCEDURE Application.ScreenUpdating = True Set OpenLong = Nothing end_time = Now() MsgBox (DateDiff("s", start_time, end_time)) End SubСоздание каталога и сохранение файла excel через VBA MS Excel онлайн
Я пытаюсь создать каталог в excel-VBA, а затем скопируйте файл xlsm и pdf в этот каталог.
Я могу создать каталог, но я не могу сохранить файлы в этом каталоге?
Код ниже. Буду признателен за любую оказанную помощь. Это сводит меня с ума. Все, что я делаю, это объединение имени файла и его сохранение в папку c: \ temp, но я хочу, чтобы он сохранил его в подпапку в c: \ temp
Sub Macro2() ' ' Macro2 Macro ' Dim FileName As String Dim FileName2 As String 'FileName3 As String FileName = Sheet1.TextBox1.Text FileName2 = ("C:\TEMP\" & FileName) 'CheckDir As String MsgBox (FileName2) MkDir (FileName2) ChDir (FileName2) ActiveWorkbook.SaveAs FileName:=FileName2 & FileName & "2xlsm.xlsm" _ , FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, FileName:= _ FileName2 & "FileName" & "_2xlsm.pdf", Quality:=xlQualityStandard, _ IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:= _ True End SubSolutions Collecting From Web of "Создание каталога и сохранение файла excel через VBA"
Формат FileName2 должен быть исправлен, чтобы правильно объединить FileName в создании файла. Кроме того, аргумент FileName как ExportAsFixedFormat так и ExportAsFixedFormat должен быть одинаковым, если вы хотите, чтобы файлы XLSM и PDF сохранялись в одном каталоге.
Пожалуйста, ознакомьтесь с измененным кодом ниже:
Sub Macro2() ' ' Macro2 Macro ' Dim FileName As String Dim FileName2 As String FileName = Sheet1.TextBox1.Text FileName2 = "C:\TEMP\" & FileName & "\" MsgBox (FileName2) MkDir (FileName2) ChDir (FileName2) ActiveWorkbook.SaveAs FileName:=FileName2 & FileName & "2xlsm.xlsm", _ FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, FileName:= _ FileName2 & FileName & "_2xlsm.pdf", Quality:=xlQualityStandard, _ IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:= _ True End SubВаш недостающий & "\" & (обратная косая черта) на FileName2 & "\" & FileName, _
См. Полный код
Option Explicit Sub Macro2() ' ' Macro2 Macro ' Dim FileName As String Dim FileName2 As String FileName = Sheet1.TextBox1.Text FileName2 = ("C:\TEMP\" & FileName) MsgBox (FileName2) MkDir (FileName2) ActiveWorkbook.SaveAs FileName:= _ FileName2 & "\" & FileName, _ FileFormat:=xlOpenXMLWorkbookMacroEnabled, _ CreateBackup:=False ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, FileName:= _ FileName2 & "\" & "FileName", _ Quality:=xlQualityStandard, IncludeDocProperties:=True, _ IgnorePrintAreas:=False, OpenAfterPublish:=True End SubИли просто сделайте это
FileName2 = ("C:\TEMP\" & FileName & "\")
excel.bilee.com
Excel VBA – создание нескольких файлов из данных в нескольких книгах MS Excel онлайн
Я хотел бы запустить макрос, чтобы вытащить определенные ячейки из листа, а затем создать файл с тем же именем, но как csv. Я также хотел бы запустить макрос в целой папке, так как есть 650 книг, но все они имеют одинаковый формат, и я знаю, какие ячейки я хочу.
Это то, что у меня есть до сих пор:
Sub converter() Dim oldDoc As Workbook Dim newDoc As Workbook '## Open both workbooks first: Set oldDoc = Workbooks.Open("C:\test.xls") Set newDoc = Workbooks.Open("C:\test_converted.csv") 'Store the value in a variable: impDate = oldDoc.Sheets("Input").Range("D3").Value impTime = oldDoc.Sheets("Input").Range("B6:B101").Value impNB = oldDoc.Sheets("Input").Range("C6:C101").Value impSB = oldDoc.Sheets("Input").Range("D6:D101").Value impEB = oldDoc.Sheets("Input").Range("E6:E101").Value impWB = oldDoc.Sheets("Input").Range("F6:F101").Value impLoc = oldDoc.Sheets("Input").Range("D1").Value 'Use the variable to assign a value to the other file/sheet: newDoc.Sheets("Sheet1").Range("A2:A97").Value = impDate newDoc.Sheets("Sheet1").Range("B2:B97").Value = impTime newDoc.Sheets("Sheet1").Range("C2:C97").Value = impNB newDoc.Sheets("Sheet1").Range("D2:D97").Value = impSB newDoc.Sheets("Sheet1").Range("E2:E97").Value = impEB newDoc.Sheets("Sheet1").Range("F2:F97").Value = impWB newDoc.Sheets("Sheet1").Range("G2:G97").Value = impLoc 'Close oldDoc: oldDoc.Close End SubВ основном я хочу, чтобы newDoc вытащил имя файла из oldDoc и сохранил его как csv. Затем я хотел бы иметь возможность запускать сразу несколько файлов.
Solutions Collecting From Web of "Excel VBA – создание нескольких файлов из данных в нескольких книгах"
Преобразование, когда обе рабочие книги открыты, работает и остается неизменным, следующий скелет для преобразования всех файлов:
Sub converter() Application.DisplayAlerts = False: Application.ScreenUpdating = False: Application.EnableEvents = False Const fPath As String = "C:\myPath\" ' <---- Your folder path here, dont forget \ Dim oldDoc As Workbook, newDoc As Workbook, fName As String, newName As String fName = Dir(fPath & "*.xl*") Do Until Len(fName) = 0 Set oldDoc = Workbooks.Open(fPath & fName) newName = fPath & Left(fName, InStrRev(fName, ".")) & "csv" Set newDoc = Workbooks.Add '''''''''''''''''''''''''''''''''''''''' ' ' Your conversion code here ' '''''''''''''''''''''''''''''''''''''''' newDoc.SaveAs newName, xlCSV newDoc.Close False oldDoc.Close False fName = Dir Loop Cleanup: If Err.Number <> 0 Then MsgBox Err.Description Application.DisplayAlerts = True: Application.ScreenUpdating = True: Application.EnableEvents = True End Subexcel.bilee.com
VBA создает текстовые файлы в цикле с листа MS Excel онлайн
Я пытаюсь создать цикл для обработки нескольких файлов excel и создавать для каждого текстового файла Excel. Я прошел долгий путь, но я столкнулся с ошибкой.
У меня есть три части кода: 1) цикл, 2) некоторые вычисления 3) создание текстовых файлов. Отдельно от eachother они работают как шарм, но когда я помещаю их в одиночный sub (как показано в Loop ниже), я получаю «Bad file mode (Error 54)» для команды [Print # 1, Left $ (strOutput , Len (strOutput) – 1) 'strString] при создании текстового файла. Я не могу понять, почему существует конфликт между разными кодами.
Цикл как
Sub GEF_Processor() Dim i As Integer Dim fd As FileDialog Set fd = Application.FileDialog(msoFileDialogFilePicker) With fd .AllowMultiSelect = True .Show End With For i = 1 To fd.SelectedItems.Count addNewWorkBook (fd.SelectedItems.Item(i)) Call macro3 Next i Set fd = Nothing End SubСоздание текстовых файлов
Sub macro3() Dim hndFile As Long Dim intColumn As Integer Dim intLast_Column As Integer Dim lngLast_Row As Long Dim lngRow As Long Dim strOutput As String intLast_Column = Worksheets("CPT_DEL_AFT").UsedRange.Column - 1 + Worksheets("CPT_DEL_AFT").UsedRange.Columns.Count lngLast_Row = Worksheets("CPT_DEL_AFT").UsedRange.Rows(Worksheets("CPT_DEL_AFT").UsedRange.Row s.Count).Row hndFile = FreeFile Open "-DEL_AFT.gef" For Output As hndFile For lngRow = 1& To lngLast_Row strOutput = "" For intColumn = 1 To intLast_Column strOutput = strOutput & Worksheets("CPT_DEL_AFT").Cells(lngRow, intColumn).Value & " " Next intColumn If Len(Trim$(Replace(strOutput, ";", ""))) > 0 Then Print hndFile, Left$(strOutput, Len(strOutput) - 1) ' strString End If Next lngRow Close #hndFile End SubSolutions Collecting From Web of "VBA создает текстовые файлы в цикле с листа"
В вашем коде немного несогласованности, вы используете hndFile для создания файла и # 1 для печати:
Open strName & "-DEL_AFT.gef" For Output As hndFileА также:
Print #1, Left$(strOutput, Len(strOutput) - 1)Чтобы сохранить согласованность, измените оператор Print следующим образом:
Print #hndFile, Left$(strOutput, Len(strOutput) - 1)excel.bilee.com
