Прошу помочь в доработке макроса, который бы выполнял сохранение выделенного диапазона листа в текстовый документ с разделителями табуляции, желательно также запрашивая новое имя файла (желательно, но не обязательно. будет достаточно указания на директорию сохранения)
Есть следующий макрос:
[vba]
Код
Sub Txt_Save() Dim Nam As String Nam = InputBox(Prompt:="Укажите имя файла", Title:="Выберите имя") Selection.Copy Application.ScreenUpdating = False Application.DisplayAlerts = False Workbooks.Add ActiveSheet.Paste ActiveWorkbook.SaveAs Filename:="D:\" & Nam & ".txt", FileFormat:= _ xlText, CreateBackup:=False ActiveWorkbook.Close Application.DisplayAlerts = True Application.ScreenUpdating = True End Sub
[/vba]
Проблема в том, что в нужном фрагменте присутствуют даты в формате дд.мм.гггг и дд.мм.гг, которые после исполнения макроса меняют формат на м/дд/гг и дд/мм/гг соответственно. Это для меня недопустимо. Если же я выполняю всю операцию вручную (копирую диапазон, создаю новую книгу, вставляю и сохраняю в нужном формате) таких изменений не происходит и все ОК. Но это несколько неудобно.
Прошу помочь не очень опытному в этом вопросе человеку)
Доброго вам, Уважаемые специалисты!
Прошу помочь в доработке макроса, который бы выполнял сохранение выделенного диапазона листа в текстовый документ с разделителями табуляции, желательно также запрашивая новое имя файла (желательно, но не обязательно. будет достаточно указания на директорию сохранения)
Есть следующий макрос:
[vba]
Код
Sub Txt_Save() Dim Nam As String Nam = InputBox(Prompt:="Укажите имя файла", Title:="Выберите имя") Selection.Copy Application.ScreenUpdating = False Application.DisplayAlerts = False Workbooks.Add ActiveSheet.Paste ActiveWorkbook.SaveAs Filename:="D:\" & Nam & ".txt", FileFormat:= _ xlText, CreateBackup:=False ActiveWorkbook.Close Application.DisplayAlerts = True Application.ScreenUpdating = True End Sub
[/vba]
Проблема в том, что в нужном фрагменте присутствуют даты в формате дд.мм.гггг и дд.мм.гг, которые после исполнения макроса меняют формат на м/дд/гг и дд/мм/гг соответственно. Это для меня недопустимо. Если же я выполняю всю операцию вручную (копирую диапазон, создаю новую книгу, вставляю и сохраняю в нужном формате) таких изменений не происходит и все ОК. Но это несколько неудобно.
Прошу помочь не очень опытному в этом вопросе человеку)Ivar
Sub IntoTxt() Dim x, y(), fName$, i&, j&, s$ x = Intersect(ActiveSheet.UsedRange, Selection).Value If Not IsArray(x) Then Exit Sub fName = InputBox(Prompt:="Укажите имя файла", Title:="Выберите имя") If fName = vbNullString Then Exit Sub ReDim y(1 To UBound(x)) For i = 1 To UBound(x) For j = 1 To UBound(x, 2) y(i) = y(i) & x(i, j) Next j Next i: s = Join(y, vbCrLf) 'MsgBox "s created" & Len(s) With CreateObject("scripting.filesystemobject") With .CreateTextFile("D:\" & fName & ".txt", True) .Write s: .Close End With End With MsgBox "Ok" End Sub
[/vba]
или так (из закромов ) [vba]
Код
Sub IntoTxt() Dim x, y(), fName$, i&, j&, s$ x = Intersect(ActiveSheet.UsedRange, Selection).Value If Not IsArray(x) Then Exit Sub fName = InputBox(Prompt:="Укажите имя файла", Title:="Выберите имя") If fName = vbNullString Then Exit Sub ReDim y(1 To UBound(x)) For i = 1 To UBound(x) For j = 1 To UBound(x, 2) y(i) = y(i) & x(i, j) Next j Next i: s = Join(y, vbCrLf) 'MsgBox "s created" & Len(s) With CreateObject("scripting.filesystemobject") With .CreateTextFile("D:\" & fName & ".txt", True) .Write s: .Close End With End With MsgBox "Ok" End Sub
Я посмотрел на топик и со стыдом вспомнил, что меня ребята на работе ещё месяца два назад просили сделать им нечто подобное, а я закрутился и забыл... А теперь вспомнил и дополировал код Николая: [vba]
Код
Sub ExportSelectionIntoTxt() Dim X, Y, i&, j&, FileName X = Intersect(ActiveSheet.UsedRange, ActiveWindow.RangeSelection).Value If Not IsArray(X) Then MsgBox "Выбрана всего одна ячейка", 48, "Экспорт не выполнен!": Exit Sub ReDim Y(1 To UBound(X)) For i = 1 To UBound(X) For j = 1 To UBound(X, 2) Y(i) = Y(i) & IIf(j = 1, "", vbTab) & X(i, j) Next j Next i Y = Join(Y, vbCrLf) X = Left(ActiveWorkbook.Name, InStrRev(ActiveWorkbook.Name, ".")) & "txt" FileName = Application.GetSaveAsFilename(InitialFileName:=X, FileFilter:="Text Files (*.txt), *.txt") If VarType(FileName) = vbBoolean Then Exit Sub ' если нажали "Отмена", то FileName = False FileName = Left(FileName, InStrRev(FileName, ".")) & "txt" With CreateObject("Scripting.FileSystemObject") With .CreateTextFile(FileName, True): .Write Y: .Close: End With End With MsgBox "Выбранный диапазон экспортирован в файл" & vbCrLf & FileName, 64, "Экспорт выполнен успешно!" End Sub
[/vba]
Я посмотрел на топик и со стыдом вспомнил, что меня ребята на работе ещё месяца два назад просили сделать им нечто подобное, а я закрутился и забыл... А теперь вспомнил и дополировал код Николая: [vba]
Код
Sub ExportSelectionIntoTxt() Dim X, Y, i&, j&, FileName X = Intersect(ActiveSheet.UsedRange, ActiveWindow.RangeSelection).Value If Not IsArray(X) Then MsgBox "Выбрана всего одна ячейка", 48, "Экспорт не выполнен!": Exit Sub ReDim Y(1 To UBound(X)) For i = 1 To UBound(X) For j = 1 To UBound(X, 2) Y(i) = Y(i) & IIf(j = 1, "", vbTab) & X(i, j) Next j Next i Y = Join(Y, vbCrLf) X = Left(ActiveWorkbook.Name, InStrRev(ActiveWorkbook.Name, ".")) & "txt" FileName = Application.GetSaveAsFilename(InitialFileName:=X, FileFilter:="Text Files (*.txt), *.txt") If VarType(FileName) = vbBoolean Then Exit Sub ' если нажали "Отмена", то FileName = False FileName = Left(FileName, InStrRev(FileName, ".")) & "txt" With CreateObject("Scripting.FileSystemObject") With .CreateTextFile(FileName, True): .Write Y: .Close: End With End With MsgBox "Выбранный диапазон экспортирован в файл" & vbCrLf & FileName, 64, "Экспорт выполнен успешно!" End Sub
День добрый уважаемые! Далёк от VBA (специализация иная), но чутьё подсказывает что диапазон выделенных ячеек выбирается с помощью RangeSelection. Задачка стоИт немного другая - выделение отдельно стоящих ячеек (с помощью CTRL) с последующим сохранением в .txt. Будьте добры, подскажите как изменить этот макрос для сохранения отдельных ячеек, иначе пишет "Выбрана всего одна ячейка". Заранее благодарен.
День добрый уважаемые! Далёк от VBA (специализация иная), но чутьё подсказывает что диапазон выделенных ячеек выбирается с помощью RangeSelection. Задачка стоИт немного другая - выделение отдельно стоящих ячеек (с помощью CTRL) с последующим сохранением в .txt. Будьте добры, подскажите как изменить этот макрос для сохранения отдельных ячеек, иначе пишет "Выбрана всего одна ячейка". Заранее благодарен.Интересующийся
Нашёл решение экспорта выделенных ячеек, в том числе и диапазоном, в текстовый файл http://www.cpearson.com/excel/ImpText.aspx Спасибо всем откликнувшимся, проблемка мизерной задачки снята!
Нашёл решение экспорта выделенных ячеек, в том числе и диапазоном, в текстовый файл http://www.cpearson.com/excel/ImpText.aspx Спасибо всем откликнувшимся, проблемка мизерной задачки снята!Интересующийся
Задачка стоИт немного другая - выделение отдельно стоящих ячеек (с помощью CTRL) с последующим сохранением в .txt.
Тот макрос экспортирует только из одного непрерывного диапазона, а не из разрозненных областей, выбранных с зажатым Ctrl Там явно должен быть цикл перебора Selection.Areas с вложенными циклами по непрерывным диапазонам ячейкек каждой .Area
Задачка стоИт немного другая - выделение отдельно стоящих ячеек (с помощью CTRL) с последующим сохранением в .txt.
Тот макрос экспортирует только из одного непрерывного диапазона, а не из разрозненных областей, выбранных с зажатым Ctrl Там явно должен быть цикл перебора Selection.Areas с вложенными циклами по непрерывным диапазонам ячейкек каждой .AreaAlex_ST
Я ещё раз подчёркиваю что не знаком с VBA, у меня другая специализация, поэтому и обратился на это ресурс. Я не знаком со списком операторов этого языка и не знаю, какие должны из них применяться в случае перебора по всем ячейкам. Обратил внимание только на "верблюжий" синтаксис. Маленькое "но": странно, но факт - импортировав 2 модуля с вышеуказанной мною ссылки в документ и выбрав различные ячейки в таблице с помощью Ctrl, они, ячейки, сохраняются в текстовом файле именно те, которые были выбраны. Можете сами проверить, это быстро.
Я ещё раз подчёркиваю что не знаком с VBA, у меня другая специализация, поэтому и обратился на это ресурс. Я не знаком со списком операторов этого языка и не знаю, какие должны из них применяться в случае перебора по всем ячейкам. Обратил внимание только на "верблюжий" синтаксис. Маленькое "но": странно, но факт - импортировав 2 модуля с вышеуказанной мною ссылки в документ и выбрав различные ячейки в таблице с помощью Ctrl, они, ячейки, сохраняются в текстовом файле именно те, которые были выбраны. Можете сами проверить, это быстро.Интересующийся
Интересующийся, Вы меня обманываете. Модернизировать свой макрос под перебор по очереди ячеек каждой из выделенных областей у меня нет сейчас ни времени, ни большого желания (уж, извините). Но проверить макрос, ссылку на который Вы дали, я всё-таки удосужился (гордость заела ). Не экспортируются области, выделенные через Ctrl! Можете проверить на моём примере. Выделите ячейки А1, В2, С3 (диагональ) и экспортируйте - получите совсем не то, что ожидали.
Интересующийся, Вы меня обманываете. Модернизировать свой макрос под перебор по очереди ячеек каждой из выделенных областей у меня нет сейчас ни времени, ни большого желания (уж, извините). Но проверить макрос, ссылку на который Вы дали, я всё-таки удосужился (гордость заела ). Не экспортируются области, выделенные через Ctrl! Можете проверить на моём примере. Выделите ячейки А1, В2, С3 (диагональ) и экспортируйте - получите совсем не то, что ожидали.Alex_ST
Неожиданно образовалось немного свободного времени на работе... Допилил процедуру под обработку раздробленного диапазона (набранного с зажатым Ctrl):[vba]
Код
Sub Export_Selection_Into_Txt() ' экспорт выбранных диапазонов в текстовой файл Dim rArea As Range, i&, j&, X, Y, Z$, FileName For Each rArea In Intersect(ActiveSheet.UsedRange, ActiveWindow.RangeSelection).Areas X = rArea.Value ' диапазон —> в массив If Not IsArray(X) Then ' если это не массив, то значит одна ячейка Y = X Else ReDim Y(1 To UBound(X)) For i = 1 To UBound(X) For j = 1 To UBound(X, 2) ' собираем значения по ячейкам строк с разделителями vbTab Y(i) = Y(i) & IIf(j = 1, "", vbTab) & X(i, j) Next j Next i Y = Join(Y, vbCrLf) ' собираем строки с разделителем vbCrLf End If Z = Z & Y & vbCrLf & "-----------" & vbCrLf ' собираем области с разделителем vbCrLf & "-----------" & vbCrLf Next rArea 'Debug.Print Z X = Left(ActiveWorkbook.Name, InStrRev(ActiveWorkbook.Name, ".")) & "txt" FileName = Application.GetSaveAsFilename(InitialFileName:=X, FileFilter:="Text Files (*.txt), *.txt") If VarType(FileName) = vbBoolean Then Exit Sub ' если нажали "Отмена", то FileName = False FileName = Left(FileName, InStrRev(FileName, ".")) & "txt" With CreateObject("Scripting.FileSystemObject") With .CreateTextFile(FileName, True): .Write Y: .Close: End With End With MsgBox "Выбранный диапазон экспортирован в файл" & vbCrLf & FileName, 64, "Экспорт выполнен успешно!" End Sub
[/vba]
Неожиданно образовалось немного свободного времени на работе... Допилил процедуру под обработку раздробленного диапазона (набранного с зажатым Ctrl):[vba]
Код
Sub Export_Selection_Into_Txt() ' экспорт выбранных диапазонов в текстовой файл Dim rArea As Range, i&, j&, X, Y, Z$, FileName For Each rArea In Intersect(ActiveSheet.UsedRange, ActiveWindow.RangeSelection).Areas X = rArea.Value ' диапазон —> в массив If Not IsArray(X) Then ' если это не массив, то значит одна ячейка Y = X Else ReDim Y(1 To UBound(X)) For i = 1 To UBound(X) For j = 1 To UBound(X, 2) ' собираем значения по ячейкам строк с разделителями vbTab Y(i) = Y(i) & IIf(j = 1, "", vbTab) & X(i, j) Next j Next i Y = Join(Y, vbCrLf) ' собираем строки с разделителем vbCrLf End If Z = Z & Y & vbCrLf & "-----------" & vbCrLf ' собираем области с разделителем vbCrLf & "-----------" & vbCrLf Next rArea 'Debug.Print Z X = Left(ActiveWorkbook.Name, InStrRev(ActiveWorkbook.Name, ".")) & "txt" FileName = Application.GetSaveAsFilename(InitialFileName:=X, FileFilter:="Text Files (*.txt), *.txt") If VarType(FileName) = vbBoolean Then Exit Sub ' если нажали "Отмена", то FileName = False FileName = Left(FileName, InStrRev(FileName, ".")) & "txt" With CreateObject("Scripting.FileSystemObject") With .CreateTextFile(FileName, True): .Write Y: .Close: End With End With MsgBox "Выбранный диапазон экспортирован в файл" & vbCrLf & FileName, 64, "Экспорт выполнен успешно!" End Sub