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

Вход

Регистрация

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

 

= Мир MS Excel/Экспортирование таблицы excel в новый фаил .xlsx - Мир MS Excel

Старая форма входа
  • Страница 1 из 1
  • 1
Модератор форума: китин, _Boroda_  
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Экспортирование таблицы excel в новый фаил .xlsx (Макросы/Sub)
Экспортирование таблицы excel в новый фаил .xlsx
Александр7034 Дата: Вторник, 26.04.2022, 11:31 | Сообщение № 1
Группа: Пользователи
Ранг: Новичок
Сообщений: 29
Репутация: 0 ±
Замечаний: 20% ±

Здравствуйте. Для упрощения работы нужна помощь. Сделал документ excel в которой генерируются наименования товара и присваиваемые ему номера кодов в зависимости от вводных данных. На первом листе "Вводные для печати" формируется таблица данных, на втором листе "На печать" итоговая таблица. В зависимости от данных количество строк может быть разным, когда 5, когда 1005 единиц товара. Вот эту таблицу каждый раз вручную приходится копировать и экспортировать в новый фаил excel (софт принтера может использовать эти таблицы, но не различает данные и пустые ячейки в которых прописана только формула). Каталог и имя экспортируемого фаила должны быть такими C:\Печать этикеток\Этикетки на печать.xlsx) В вложении максимально упрощеная заготовка с описанием.
К сообщению приложен файл: 9210433.xlsx(31.7 Kb)
 
Ответить
СообщениеЗдравствуйте. Для упрощения работы нужна помощь. Сделал документ excel в которой генерируются наименования товара и присваиваемые ему номера кодов в зависимости от вводных данных. На первом листе "Вводные для печати" формируется таблица данных, на втором листе "На печать" итоговая таблица. В зависимости от данных количество строк может быть разным, когда 5, когда 1005 единиц товара. Вот эту таблицу каждый раз вручную приходится копировать и экспортировать в новый фаил excel (софт принтера может использовать эти таблицы, но не различает данные и пустые ячейки в которых прописана только формула). Каталог и имя экспортируемого фаила должны быть такими C:\Печать этикеток\Этикетки на печать.xlsx) В вложении максимально упрощеная заготовка с описанием.

Автор - Александр7034
Дата добавления - 26.04.2022 в 11:31
jun Дата: Пятница, 29.04.2022, 16:00 | Сообщение № 2
Группа: Пользователи
Ранг: Участник
Сообщений: 84
Репутация: 18 ±
Замечаний: 0% ±

можно так:
[vba]
Код
Sub Экспорт()
Dim wb As Workbook, arr(), DataArr, i As Long, j As Long, item As Long, cnt As Long
Application.DisplayAlerts = False
Application.ScreenUpdating = False
With ThisWorkbook.Sheets("На печать")
DataArr = Application.Transpose(.Cells(1, 1).CurrentRegion)
i = 1: cnt = 1
item = Application.Match(0, .Columns(2), 0)
Do
    For j = 1 To UBound(DataArr, 1)
        ReDim Preserve arr(1 To UBound(DataArr, 1), 1 To cnt)
        arr(j, cnt) = DataArr(j, i)
    Next j
    i = i + 1
    cnt = cnt + 1
Loop While i < item

    Set wb = Application.Workbooks.Add
    wb.Sheets(1).Cells(1, 1).Resize(UBound(arr, 2), UBound(arr, 1)) = Application.Transpose(arr)
    wb.SaveAs "C:\Печать этикеток\Этикетки на печать.xlsx"
    wb.Close True
End With
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
[/vba]

или короче:
[vba]
Код
Sub Экспорт_2()
Dim wb As Workbook, item
Application.DisplayAlerts = False
Application.ScreenUpdating = False
With ThisWorkbook.Sheets("На печать")
    item = Application.Match(0, .Columns(2), 0)
    Set wb = Application.Workbooks.Add
    .Range(.Cells(1, 1), .Cells(item - 1, 3)).Copy wb.Sheets(1).Cells(1, 1)
    wb.SaveAs "C:\Печать этикеток\Этикетки на печать.xlsx"
    wb.Close True
End With
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
[/vba]
К сообщению приложен файл: 0732123.xlsb(30.4 Kb)


Сообщение отредактировал jun - Пятница, 29.04.2022, 16:10
 
Ответить
Сообщениеможно так:
[vba]
Код
Sub Экспорт()
Dim wb As Workbook, arr(), DataArr, i As Long, j As Long, item As Long, cnt As Long
Application.DisplayAlerts = False
Application.ScreenUpdating = False
With ThisWorkbook.Sheets("На печать")
DataArr = Application.Transpose(.Cells(1, 1).CurrentRegion)
i = 1: cnt = 1
item = Application.Match(0, .Columns(2), 0)
Do
    For j = 1 To UBound(DataArr, 1)
        ReDim Preserve arr(1 To UBound(DataArr, 1), 1 To cnt)
        arr(j, cnt) = DataArr(j, i)
    Next j
    i = i + 1
    cnt = cnt + 1
Loop While i < item

    Set wb = Application.Workbooks.Add
    wb.Sheets(1).Cells(1, 1).Resize(UBound(arr, 2), UBound(arr, 1)) = Application.Transpose(arr)
    wb.SaveAs "C:\Печать этикеток\Этикетки на печать.xlsx"
    wb.Close True
End With
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
[/vba]

или короче:
[vba]
Код
Sub Экспорт_2()
Dim wb As Workbook, item
Application.DisplayAlerts = False
Application.ScreenUpdating = False
With ThisWorkbook.Sheets("На печать")
    item = Application.Match(0, .Columns(2), 0)
    Set wb = Application.Workbooks.Add
    .Range(.Cells(1, 1), .Cells(item - 1, 3)).Copy wb.Sheets(1).Cells(1, 1)
    wb.SaveAs "C:\Печать этикеток\Этикетки на печать.xlsx"
    wb.Close True
End With
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
[/vba]

Автор - jun
Дата добавления - 29.04.2022 в 16:00
Al1978 Дата: Воскресенье, 01.05.2022, 08:37 | Сообщение № 3
Группа: Пользователи
Ранг: Прохожий
Сообщений: 2
Репутация: 0 ±
Замечаний: 0% ±

Доброго времени суток, форумчане. Прошу помощи, поскольку только начал разбираться с VBA, а сделать надо срочно....Имеется таблица. Во втором столбце встречаются одинаковые фамилии. Нужно создать новую таблицу, которая при вызове макросы создает таблицу, в которой находятся одинаковые значения из столбца 2, а в остальных столбцах новой таблицы остальные значения из первой таблицы. (если это возможно, то только те значения, которые соответствуют, где одно из значений в столбце "а" соответствует необходимому значению месяца. Для наглядности приложил файл. Буду очень благодарен за любую помощь!!!
К сообщению приложен файл: 11111.xlsx(10.7 Kb)


Сообщение отредактировал Al1978 - Воскресенье, 01.05.2022, 08:47
 
Ответить
СообщениеДоброго времени суток, форумчане. Прошу помощи, поскольку только начал разбираться с VBA, а сделать надо срочно....Имеется таблица. Во втором столбце встречаются одинаковые фамилии. Нужно создать новую таблицу, которая при вызове макросы создает таблицу, в которой находятся одинаковые значения из столбца 2, а в остальных столбцах новой таблицы остальные значения из первой таблицы. (если это возможно, то только те значения, которые соответствуют, где одно из значений в столбце "а" соответствует необходимому значению месяца. Для наглядности приложил файл. Буду очень благодарен за любую помощь!!!

Автор - Al1978
Дата добавления - 01.05.2022 в 08:37
jun Дата: Воскресенье, 01.05.2022, 10:51 | Сообщение № 4
Группа: Пользователи
Ранг: Участник
Сообщений: 84
Репутация: 18 ±
Замечаний: 0% ±

Al1978, приветствую! Можно так:
[vba]
Код
Sub macro_1()
Dim Dict As Object, item, j, h, a
Dim arr, lstRow As Long
Set Dict = CreateObject("Scripting.Dictionary")
With Dict
    .CompareMode = vbTextCompare
End With
arr = Application.Transpose(Application.InputBox("Выберите диапазон для преобразования", Type:=8))

    For j = LBound(arr, 2) To UBound(arr, 2)
        If Not Dict.exists(arr(2, j)) Then
            Dict.Add arr(2, j), arr(3, j) & ";" & arr(1, j) & ";" & arr(4, j)
        Else
            Dict.item(arr(2, j)) = _
                Dict.item(arr(2, j)) & "|" & arr(3, j) & ";" & arr(1, j) & ";" & arr(4, j)
        End If
    Next j
With Sheets("Лист2") ' Лист2 поменять на нужное имя листа
    lstRow = .Cells(.Rows.Count, 1).End(xlUp).Row
    For Each h In Dict.keys
        item = Split(Dict.item(h), "|")
        .Cells(lstRow, 1).Resize(UBound(item) + 1, 1) = h
        For Each a In item
            a = Split(a, ";")
            .Cells(lstRow, 2).Resize(1, UBound(a) + 1) = a
            lstRow = lstRow + 1
        Next a
    Next h
End With
End Sub
[/vba]
Потом объединить ячейки по Фамилии.
К сообщению приложен файл: 11111.xlsb(19.6 Kb)


Сообщение отредактировал jun - Воскресенье, 01.05.2022, 11:02
 
Ответить
СообщениеAl1978, приветствую! Можно так:
[vba]
Код
Sub macro_1()
Dim Dict As Object, item, j, h, a
Dim arr, lstRow As Long
Set Dict = CreateObject("Scripting.Dictionary")
With Dict
    .CompareMode = vbTextCompare
End With
arr = Application.Transpose(Application.InputBox("Выберите диапазон для преобразования", Type:=8))

    For j = LBound(arr, 2) To UBound(arr, 2)
        If Not Dict.exists(arr(2, j)) Then
            Dict.Add arr(2, j), arr(3, j) & ";" & arr(1, j) & ";" & arr(4, j)
        Else
            Dict.item(arr(2, j)) = _
                Dict.item(arr(2, j)) & "|" & arr(3, j) & ";" & arr(1, j) & ";" & arr(4, j)
        End If
    Next j
With Sheets("Лист2") ' Лист2 поменять на нужное имя листа
    lstRow = .Cells(.Rows.Count, 1).End(xlUp).Row
    For Each h In Dict.keys
        item = Split(Dict.item(h), "|")
        .Cells(lstRow, 1).Resize(UBound(item) + 1, 1) = h
        For Each a In item
            a = Split(a, ";")
            .Cells(lstRow, 2).Resize(1, UBound(a) + 1) = a
            lstRow = lstRow + 1
        Next a
    Next h
End With
End Sub
[/vba]
Потом объединить ячейки по Фамилии.

Автор - jun
Дата добавления - 01.05.2022 в 10:51
Al1978 Дата: Понедельник, 02.05.2022, 08:10 | Сообщение № 5
Группа: Пользователи
Ранг: Прохожий
Сообщений: 2
Репутация: 0 ±
Замечаний: 0% ±

jun, СПАСИБО, ОГРОМНОЕ!!! Почти то, что необходимо.
Далее "для придания соответствующей формы доработаю напильником"))))
 
Ответить
Сообщениеjun, СПАСИБО, ОГРОМНОЕ!!! Почти то, что необходимо.
Далее "для придания соответствующей формы доработаю напильником"))))

Автор - Al1978
Дата добавления - 02.05.2022 в 08:10
Александр7034 Дата: Четверг, 05.05.2022, 09:21 | Сообщение № 6
Группа: Пользователи
Ранг: Новичок
Сообщений: 29
Репутация: 0 ±
Замечаний: 20% ±

Sub Экспорт_2()
Спасибо то что нужно. А что нужно прописать в короткий код что бы ширина таблиц была заданной? А то после экспорта столбцы стандартные, соответствено текст в ячейках не помещается.


Сообщение отредактировал Serge_007 - Четверг, 05.05.2022, 09:51
 
Ответить
Сообщение
Sub Экспорт_2()
Спасибо то что нужно. А что нужно прописать в короткий код что бы ширина таблиц была заданной? А то после экспорта столбцы стандартные, соответствено текст в ячейках не помещается.

Автор - Александр7034
Дата добавления - 05.05.2022 в 09:21
jun Дата: Среда, 11.05.2022, 14:42 | Сообщение № 7
Группа: Пользователи
Ранг: Участник
Сообщений: 84
Репутация: 18 ±
Замечаний: 0% ±

Александр7034, прошу прощения за долгий ответ, не увидел сразу Ваше сообщение
[vba]
Код
wb.Sheets(1).Columns.AutoFit ' вот эту строку
[/vba]
см. код ниже:
[vba]
Код
Sub Экспорт_2()
Dim wb As Workbook, item
Application.DisplayAlerts = False
Application.ScreenUpdating = False
With ThisWorkbook.Sheets("На печать")
    item = Application.Match(0, .Columns(2), 0)
    Set wb = Application.Workbooks.Add
    .Range(.Cells(1, 1), .Cells(item - 1, 3)).Copy wb.Sheets(1).Cells(1, 1)
    wb.Sheets(1).Columns.AutoFit ' вот эту строку
    wb.SaveAs "C:\Печать этикеток\Этикетки на печать.xlsx"
    wb.Close True
End With
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
[/vba]
 
Ответить
СообщениеАлександр7034, прошу прощения за долгий ответ, не увидел сразу Ваше сообщение
[vba]
Код
wb.Sheets(1).Columns.AutoFit ' вот эту строку
[/vba]
см. код ниже:
[vba]
Код
Sub Экспорт_2()
Dim wb As Workbook, item
Application.DisplayAlerts = False
Application.ScreenUpdating = False
With ThisWorkbook.Sheets("На печать")
    item = Application.Match(0, .Columns(2), 0)
    Set wb = Application.Workbooks.Add
    .Range(.Cells(1, 1), .Cells(item - 1, 3)).Copy wb.Sheets(1).Cells(1, 1)
    wb.Sheets(1).Columns.AutoFit ' вот эту строку
    wb.SaveAs "C:\Печать этикеток\Этикетки на печать.xlsx"
    wb.Close True
End With
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
[/vba]

Автор - jun
Дата добавления - 11.05.2022 в 14:42
Александр7034 Дата: Пятница, 13.05.2022, 11:49 | Сообщение № 8
Группа: Пользователи
Ранг: Новичок
Сообщений: 29
Репутация: 0 ±
Замечаний: 20% ±

jun, а не подскажите, при копировании кода уже в мой проект, выходит сообщение об ошибке при выполнении и выделена следующая строка в debug
Код
.Range(.Cells(1, 1), .Cells(item - 1, 3)).Copy wb.Sheets(1).Cells(1, 1)

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


Сообщение отредактировал Александр7034 - Пятница, 13.05.2022, 14:02
 
Ответить
Сообщениеjun, а не подскажите, при копировании кода уже в мой проект, выходит сообщение об ошибке при выполнении и выделена следующая строка в debug
Код
.Range(.Cells(1, 1), .Cells(item - 1, 3)).Copy wb.Sheets(1).Cells(1, 1)

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

Автор - Александр7034
Дата добавления - 13.05.2022 в 11:49
jun Дата: Пятница, 13.05.2022, 14:45 | Сообщение № 9
Группа: Пользователи
Ранг: Участник
Сообщений: 84
Репутация: 18 ±
Замечаний: 0% ±

Александр7034, можете подсказать, какая ошибка? Что пишет?
Может быть item не определилась из-за того что отсутствуют нули во втором столбце после значений? Можно посмотреть в Locals Window (Alt + F11 -> View -> Locals Window)
 
Ответить
СообщениеАлександр7034, можете подсказать, какая ошибка? Что пишет?
Может быть item не определилась из-за того что отсутствуют нули во втором столбце после значений? Можно посмотреть в Locals Window (Alt + F11 -> View -> Locals Window)

Автор - jun
Дата добавления - 13.05.2022 в 14:45
Александр7034 Дата: Вторник, 17.05.2022, 08:59 | Сообщение № 10
Группа: Пользователи
Ранг: Новичок
Сообщений: 29
Репутация: 0 ±
Замечаний: 20% ±

Так и оказалось, опытным путем выяснил что нули являются завершающий строкой.
А не подскажите какую строку в вашем коде выше нужно прописать, что бы появлялась надпись "выполнено", а то по началу так хорошо импортировалось без всяких надписей, что подумал код не работает, так как визуально ни чего не произошло.


Сообщение отредактировал Serge_007 - Вторник, 17.05.2022, 09:03
 
Ответить
СообщениеТак и оказалось, опытным путем выяснил что нули являются завершающий строкой.
А не подскажите какую строку в вашем коде выше нужно прописать, что бы появлялась надпись "выполнено", а то по началу так хорошо импортировалось без всяких надписей, что подумал код не работает, так как визуально ни чего не произошло.

Автор - Александр7034
Дата добавления - 17.05.2022 в 08:59
_Boroda_ Дата: Вторник, 17.05.2022, 09:08 | Сообщение № 11
Группа: Модераторы
Ранг: Местный житель
Сообщений: 16359
Репутация: 6352 ±
Замечаний: 0% ±

2003; 2007; 2010; 2013 RUS
Предпоследнюю строку добавьте вот такую
[vba]
Код
MsgBox "Выполнено"
End Sub
[/vba]


Скажи мне, кудесник, любимец ба’гов...
Платная помощь:
Boroda_Excel@mail.ru
Яндекс-деньги: 41001632713405 | Webmoney: R289877159277; Z102172301748; E177867141995
 
Ответить
СообщениеПредпоследнюю строку добавьте вот такую
[vba]
Код
MsgBox "Выполнено"
End Sub
[/vba]

Автор - _Boroda_
Дата добавления - 17.05.2022 в 09:08
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Экспортирование таблицы excel в новый фаил .xlsx (Макросы/Sub)
  • Страница 1 из 1
  • 1
Поиск:

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