Домашняя страница Undo Do New Save Карта сайта Обратная связь Поиск по форуму
МИР MS EXCEL - Гость.xls

Вход

Регистрация

Напомнить пароль

 

= Мир MS Excel/Макрос, сохраняющий выделенное в тхт с раздел-м табуляции - Мир MS Excel

Старая форма входа
  • Страница 1 из 1
  • 1
Модератор форума: китин, _Boroda_  
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Макрос, сохраняющий выделенное в тхт с раздел-м табуляции (Прошу помочь в доработке макроса)
Макрос, сохраняющий выделенное в тхт с раздел-м табуляции
Ivar Дата: Вторник, 09.04.2013, 10:39 | Сообщение № 1
Группа: Пользователи
Ранг: Прохожий
Сообщений: 2
Репутация: 0 ±
Замечаний: 0% ±

Доброго вам, Уважаемые специалисты!

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

Есть следующий макрос:

[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]

Проблема в том, что в нужном фрагменте присутствуют даты в формате дд.мм.гггг и дд.мм.гг, которые после исполнения макроса меняют формат на м/дд/гг и дд/мм/гг соответственно. Это для меня недопустимо.
Если же я выполняю всю операцию вручную (копирую диапазон, создаю новую книгу, вставляю и сохраняю в нужном формате) таких изменений не происходит и все ОК. Но это несколько неудобно.

Прошу помочь не очень опытному в этом вопросе человеку)
К сообщению приложен файл: 5781906.xlsx (11.8 Kb)


Сообщение отредактировал Ivar - Вторник, 09.04.2013, 12:30
 
Ответить
СообщениеДоброго вам, Уважаемые специалисты!

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

Есть следующий макрос:

[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
Дата добавления - 09.04.2013 в 10:39
Ivar Дата: Вторник, 09.04.2013, 12:29 | Сообщение № 2
Группа: Пользователи
Ранг: Прохожий
Сообщений: 2
Репутация: 0 ±
Замечаний: 0% ±

Ответ подсказан человеком с другого ресурса.

в 10-ю строчку требуется добавить

[vba]
Код
Local:=True
[/vba]

Итог:

[vba]
Код
Sub СохранениеВТекст()
'
' СохранениеВТекст Макрос
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, Local:=True
ActiveWorkbook.Close
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
[/vba]


Сообщение отредактировал Ivar - Вторник, 09.04.2013, 12:31
 
Ответить
СообщениеОтвет подсказан человеком с другого ресурса.

в 10-ю строчку требуется добавить

[vba]
Код
Local:=True
[/vba]

Итог:

[vba]
Код
Sub СохранениеВТекст()
'
' СохранениеВТекст Макрос
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, Local:=True
ActiveWorkbook.Close
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
[/vba]

Автор - Ivar
Дата добавления - 09.04.2013 в 12:29
nilem Дата: Вторник, 09.04.2013, 12:52 | Сообщение № 3
Группа: Авторы
Ранг: Старожил
Сообщений: 1612
Репутация: 563 ±
Замечаний: 0% ±

Excel 2013, 2016
или так (из закромов smile )
[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]


Яндекс.Деньги 4100159601573
 
Ответить
Сообщениеили так (из закромов smile )
[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]

Автор - nilem
Дата добавления - 09.04.2013 в 12:52
Alex_ST Дата: Среда, 10.04.2013, 12:48 | Сообщение № 4
Группа: Друзья
Ранг: Участник клуба
Сообщений: 3198
Репутация: 606 ±
Замечаний: 0% ±

2003
Я посмотрел на топик и со стыдом вспомнил, что меня ребята на работе ещё месяца два назад просили сделать им нечто подобное, а я закрутился и забыл...
А теперь вспомнил и дополировал код Николая:
[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]



С уважением,
Алексей
MS Excel 2003 - the best!!!


Сообщение отредактировал Alex_ST - Среда, 10.04.2013, 12:49
 
Ответить
СообщениеЯ посмотрел на топик и со стыдом вспомнил, что меня ребята на работе ещё месяца два назад просили сделать им нечто подобное, а я закрутился и забыл...
А теперь вспомнил и дополировал код Николая:
[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]

Автор - Alex_ST
Дата добавления - 10.04.2013 в 12:48
Интересующийся Дата: Четверг, 20.02.2014, 14:40 | Сообщение № 5
Группа: Гости
День добрый уважаемые!
Далёк от VBA (специализация иная), но чутьё подсказывает что диапазон выделенных ячеек выбирается с помощью RangeSelection. Задачка стоИт немного другая - выделение отдельно стоящих ячеек (с помощью CTRL) с последующим сохранением в .txt.
Будьте добры, подскажите как изменить этот макрос для сохранения отдельных ячеек, иначе пишет "Выбрана всего одна ячейка".
Заранее благодарен.
 
Ответить
СообщениеДень добрый уважаемые!
Далёк от VBA (специализация иная), но чутьё подсказывает что диапазон выделенных ячеек выбирается с помощью RangeSelection. Задачка стоИт немного другая - выделение отдельно стоящих ячеек (с помощью CTRL) с последующим сохранением в .txt.
Будьте добры, подскажите как изменить этот макрос для сохранения отдельных ячеек, иначе пишет "Выбрана всего одна ячейка".
Заранее благодарен.

Автор - Интересующийся
Дата добавления - 20.02.2014 в 14:40
Hugo Дата: Четверг, 20.02.2014, 14:59 | Сообщение № 6
Группа: Друзья
Ранг: Участник клуба
Сообщений: 3250
Репутация: 707 ±
Замечаний: 0% ±

2019
"этот макрос" изменить не получится - нужно писать другой макрос.
Даже вероятно совершенно другой.


excel@nxt.ru
webmoney: E265281470651 Z422237915069
 
Ответить
Сообщение"этот макрос" изменить не получится - нужно писать другой макрос.
Даже вероятно совершенно другой.

Автор - Hugo
Дата добавления - 20.02.2014 в 14:59
Интересующийся Дата: Четверг, 20.02.2014, 16:54 | Сообщение № 7
Группа: Гости
Спасибо за оперативный отклик.
Может подскажете ссылку на готовое решение этой задачки в сети?
 
Ответить
СообщениеСпасибо за оперативный отклик.
Может подскажете ссылку на готовое решение этой задачки в сети?

Автор - Интересующийся
Дата добавления - 20.02.2014 в 16:54
Интересующийся Дата: Четверг, 20.02.2014, 18:57 | Сообщение № 8
Группа: Гости
Нашёл решение экспорта выделенных ячеек, в том числе и диапазоном, в текстовый файл http://www.cpearson.com/excel/ImpText.aspx
Спасибо всем откликнувшимся, проблемка мизерной задачки снята!
 
Ответить
СообщениеНашёл решение экспорта выделенных ячеек, в том числе и диапазоном, в текстовый файл http://www.cpearson.com/excel/ImpText.aspx
Спасибо всем откликнувшимся, проблемка мизерной задачки снята!

Автор - Интересующийся
Дата добавления - 20.02.2014 в 18:57
Alex_ST Дата: Четверг, 20.02.2014, 20:57 | Сообщение № 9
Группа: Друзья
Ранг: Участник клуба
Сообщений: 3198
Репутация: 606 ±
Замечаний: 0% ±

2003
Интересующийся, просмотрев макрос на http://www.cpearson.com/excel/ImpText.aspx я что-то не увидел в нём того, что Вы хотите:
Цитата Интересующийся, 20.02.2014 в 14:40, в сообщении № 5
Задачка стоИт немного другая - выделение отдельно стоящих ячеек (с помощью CTRL) с последующим сохранением в .txt.

Тот макрос экспортирует только из одного непрерывного диапазона, а не из разрозненных областей, выбранных с зажатым Ctrl
Там явно должен быть цикл перебора Selection.Areas с вложенными циклами по непрерывным диапазонам ячейкек каждой .Area



С уважением,
Алексей
MS Excel 2003 - the best!!!
 
Ответить
СообщениеИнтересующийся, просмотрев макрос на http://www.cpearson.com/excel/ImpText.aspx я что-то не увидел в нём того, что Вы хотите:
Цитата Интересующийся, 20.02.2014 в 14:40, в сообщении № 5
Задачка стоИт немного другая - выделение отдельно стоящих ячеек (с помощью CTRL) с последующим сохранением в .txt.

Тот макрос экспортирует только из одного непрерывного диапазона, а не из разрозненных областей, выбранных с зажатым Ctrl
Там явно должен быть цикл перебора Selection.Areas с вложенными циклами по непрерывным диапазонам ячейкек каждой .Area

Автор - Alex_ST
Дата добавления - 20.02.2014 в 20:57
Интересующийся Дата: Четверг, 20.02.2014, 22:38 | Сообщение № 10
Группа: Гости
Я ещё раз подчёркиваю что не знаком с VBA, у меня другая специализация, поэтому и обратился на это ресурс. Я не знаком со списком операторов этого языка и не знаю, какие должны из них применяться в случае перебора по всем ячейкам. Обратил внимание только на "верблюжий" синтаксис.
Маленькое "но": странно, но факт - импортировав 2 модуля с вышеуказанной мною ссылки в документ и выбрав различные ячейки в таблице с помощью Ctrl, они, ячейки, сохраняются в текстовом файле именно те, которые были выбраны. Можете сами проверить, это быстро.
 
Ответить
СообщениеЯ ещё раз подчёркиваю что не знаком с VBA, у меня другая специализация, поэтому и обратился на это ресурс. Я не знаком со списком операторов этого языка и не знаю, какие должны из них применяться в случае перебора по всем ячейкам. Обратил внимание только на "верблюжий" синтаксис.
Маленькое "но": странно, но факт - импортировав 2 модуля с вышеуказанной мною ссылки в документ и выбрав различные ячейки в таблице с помощью Ctrl, они, ячейки, сохраняются в текстовом файле именно те, которые были выбраны. Можете сами проверить, это быстро.

Автор - Интересующийся
Дата добавления - 20.02.2014 в 22:38
Alex_ST Дата: Понедельник, 24.02.2014, 20:53 | Сообщение № 11
Группа: Друзья
Ранг: Участник клуба
Сообщений: 3198
Репутация: 606 ±
Замечаний: 0% ±

2003
Интересующийся, Вы меня обманываете.
Модернизировать свой макрос под перебор по очереди ячеек каждой из выделенных областей у меня нет сейчас ни времени, ни большого желания (уж, извините).
Но проверить макрос, ссылку на который Вы дали, я всё-таки удосужился (гордость заела :) ).
Не экспортируются области, выделенные через Ctrl!
Можете проверить на моём примере.
Выделите ячейки А1, В2, С3 (диагональ) и экспортируйте - получите совсем не то, что ожидали.
К сообщению приложен файл: testExportRng2T.xls (33.0 Kb)



С уважением,
Алексей
MS Excel 2003 - the best!!!
 
Ответить
СообщениеИнтересующийся, Вы меня обманываете.
Модернизировать свой макрос под перебор по очереди ячеек каждой из выделенных областей у меня нет сейчас ни времени, ни большого желания (уж, извините).
Но проверить макрос, ссылку на который Вы дали, я всё-таки удосужился (гордость заела :) ).
Не экспортируются области, выделенные через Ctrl!
Можете проверить на моём примере.
Выделите ячейки А1, В2, С3 (диагональ) и экспортируйте - получите совсем не то, что ожидали.

Автор - Alex_ST
Дата добавления - 24.02.2014 в 20:53
Alex_ST Дата: Среда, 26.02.2014, 09:48 | Сообщение № 12
Группа: Друзья
Ранг: Участник клуба
Сообщений: 3198
Репутация: 606 ±
Замечаний: 0% ±

2003
Неожиданно образовалось немного свободного времени на работе...
Допилил процедуру под обработку раздробленного диапазона (набранного с зажатым 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]



С уважением,
Алексей
MS Excel 2003 - the best!!!


Сообщение отредактировал Alex_ST - Среда, 26.02.2014, 09:50
 
Ответить
СообщениеНеожиданно образовалось немного свободного времени на работе...
Допилил процедуру под обработку раздробленного диапазона (набранного с зажатым 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]

Автор - Alex_ST
Дата добавления - 26.02.2014 в 09:48
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Макрос, сохраняющий выделенное в тхт с раздел-м табуляции (Прошу помочь в доработке макроса)
  • Страница 1 из 1
  • 1
Поиск:

Яндекс.Метрика Яндекс цитирования
© 2010-2024 · Дизайн: MichaelCH · Хостинг от uCoz · При использовании материалов сайта, ссылка на www.excelworld.ru обязательна!