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

Вход

Регистрация

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

 

= Мир MS Excel/Сохранение листа с заданным именем в отдельный файл. - Мир MS Excel

Старая форма входа
  • Страница 1 из 1
  • 1
Модератор форума: китин, _Boroda_  
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Сохранение листа с заданным именем в отдельный файл. (Макросы/Sub)
Сохранение листа с заданным именем в отдельный файл.
Alexey_1979 Дата: Среда, 13.01.2021, 08:08 | Сообщение № 1
Группа: Пользователи
Ранг: Прохожий
Сообщений: 8
Репутация: 0 ±
Замечаний: 0% ±

Excel 2019
Доброго времени суток, ГУРУ VBA. Помогите, пожалуйста с написанием макроса. Кратко опишу задачу: на ПК есть папка, в которой находится порядка 11000 однотипных по своей структуре файлов Excel("Закл.№30918-YMTP3-A-0131"). Отличие между ними, только в именах. Необходимо из каждого файла вытащить определенный лист ("УК"), сохранить его в новой книге без формул(заменить все формулы их значениями), присвоив этому файлу имя из значений в определенных ячейках("L3","M3" и "N3"). Вновь созданный файл должен сохраниться в папке по заранее заданному пути в коде макроса ("C:\УЗК"). Файл "YMTP3-A-0131UT-30917" это результат, который должен получиться.
К сообщению приложен файл: YMTP3-A-0131UT-.xlsx (19.3 Kb) · .30918-YMTP3-A-.xlsm (106.4 Kb)


Сообщение отредактировал Alexey_1979 - Среда, 13.01.2021, 08:09
 
Ответить
СообщениеДоброго времени суток, ГУРУ VBA. Помогите, пожалуйста с написанием макроса. Кратко опишу задачу: на ПК есть папка, в которой находится порядка 11000 однотипных по своей структуре файлов Excel("Закл.№30918-YMTP3-A-0131"). Отличие между ними, только в именах. Необходимо из каждого файла вытащить определенный лист ("УК"), сохранить его в новой книге без формул(заменить все формулы их значениями), присвоив этому файлу имя из значений в определенных ячейках("L3","M3" и "N3"). Вновь созданный файл должен сохраниться в папке по заранее заданному пути в коде макроса ("C:\УЗК"). Файл "YMTP3-A-0131UT-30917" это результат, который должен получиться.

Автор - Alexey_1979
Дата добавления - 13.01.2021 в 08:08
Alexey_1979 Дата: Среда, 13.01.2021, 14:03 | Сообщение № 2
Группа: Пользователи
Ранг: Прохожий
Сообщений: 8
Репутация: 0 ±
Замечаний: 0% ±

Excel 2019
РЕШЕНО
 
Ответить
СообщениеРЕШЕНО

Автор - Alexey_1979
Дата добавления - 13.01.2021 в 14:03
Pelena Дата: Среда, 13.01.2021, 14:05 | Сообщение № 3
Группа: Админы
Ранг: Местный житель
Сообщений: 19167
Репутация: 4412 ±
Замечаний: ±

Excel 365 & Mac Excel
Alexey_1979, поделиться решением не хотите? Для будущих поколений, так сказать


"Черт возьми, Холмс! Но как??!!"
Ю-money 41001765434816
 
Ответить
СообщениеAlexey_1979, поделиться решением не хотите? Для будущих поколений, так сказать

Автор - Pelena
Дата добавления - 13.01.2021 в 14:05
Serge_007 Дата: Среда, 13.01.2021, 16:10 | Сообщение № 4
Группа: Админы
Ранг: Местный житель
Сообщений: 16475
Репутация: 2748 ±
Замечаний: ±

Excel 2016
Лена, а зачем?
У нас уже неоднократно были аналогичные темы, вот, например эта, ноябрь прошлого года:
Сохранение листов каждый в отдельный файл с именем из ячейки


ЮMoney:41001419691823 | WMR:126292472390
 
Ответить
СообщениеЛена, а зачем?
У нас уже неоднократно были аналогичные темы, вот, например эта, ноябрь прошлого года:
Сохранение листов каждый в отдельный файл с именем из ячейки

Автор - Serge_007
Дата добавления - 13.01.2021 в 16:10
Pelena Дата: Среда, 13.01.2021, 16:20 | Сообщение № 5
Группа: Админы
Ранг: Местный житель
Сообщений: 19167
Репутация: 4412 ±
Замечаний: ±

Excel 365 & Mac Excel
Чтобы тема не оставалась пустой


"Черт возьми, Холмс! Но как??!!"
Ю-money 41001765434816
 
Ответить
СообщениеЧтобы тема не оставалась пустой

Автор - Pelena
Дата добавления - 13.01.2021 в 16:20
RAN Дата: Среда, 13.01.2021, 16:53 | Сообщение № 6
Группа: Друзья
Ранг: Экселист
Сообщений: 5660
Репутация: 1163 ±
Замечаний: 0% ±

2010
Лен, нет темы, нет дела...


Быть или не быть, вот в чем загвоздка!
 
Ответить
СообщениеЛен, нет темы, нет дела...

Автор - RAN
Дата добавления - 13.01.2021 в 16:53
Alexey_1979 Дата: Суббота, 16.01.2021, 06:41 | Сообщение № 7
Группа: Пользователи
Ранг: Прохожий
Сообщений: 8
Репутация: 0 ±
Замечаний: 0% ±

Excel 2019
[vba]
Код
Sub Get_All_File_from_Folder()
Dim sFolder As String, sFiles As String
Dim wb As Workbook
Dim fso As Object, foldr As Object, foldr1 As Object

Set fso = CreateObject("Scripting.FileSystemObject")

If fso.FolderExists("C:\УЗК") Or fso.FolderExists("C:\УЗК_ОБЩ") Then

Call RemovingTempFiles

Path0 = "C:\УЗК"
Path1 = "C:\УЗК_ОБЩ"
fso.CreateFolder Path0
fso.CreateFolder Path1

Else

Path0 = "C:\УЗК"
Path1 = "C:\УЗК_ОБЩ"
fso.CreateFolder Path0
fso.CreateFolder Path1

End If

Set foldr = fso.getfolder(Path0)
Set foldr1 = fso.getfolder(Path1)

'диалог запроса выбора папки с файлами
With Application.FileDialog(msoFileDialogFolderPicker)
If .Show = False Then Exit Sub
sFolder = .SelectedItems(1)
End With
sFolder = sFolder & IIf(Right(sFolder, 1) = Application.PathSeparator, "", Application.PathSeparator)

Application.ScreenUpdating = False
sFiles = Dir(sFolder & "Зак*.xls*")
Do While sFiles <> ""
'открываем книгу
Set wb = Application.Workbooks.Open(sFolder & sFiles)
'действия с файлом
FileName = Path0 & "\" & wb.Sheets("УК").Cells(3, 12) & "-" & wb.Sheets("УК").Cells(3, 13) _
& "-" & wb.Sheets("УК").Cells(3, 14) & ".xlsx"

Err.Clear: wb.Sheets("УК").Copy: DoEvents

arr = wb.Sheets("УК").UsedRange.Value

ActiveSheet.Buttons.Delete
Range("A1:R25").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False

Range("T7:U15").Select
Selection.ClearContents

Range("J27:P33").Select
Selection.EntireRow.Delete

Range("A1").Select

If Err Then Exit Sub

If ActiveWorkbook.Worksheets.Count = 1 And ActiveWorkbook.Path = "" Then

Application.DisplayAlerts = False
ActiveWorkbook.SaveAs FileName, xlOpenXMLWorkbook
ActiveWorkbook.Close True

End If

'Закрываем книгу с сохранением изменений
wb.Close False 'если поставить False - книга будет закрыта без сохранения
sFiles = Dir
Loop

Call MergingFiles

Application.ScreenUpdating = True

End Sub

Sub MergingFiles()
' Собираем все листы в новую книгу с именем ТП

Application.DisplayAlerts = False

Dim CurFile As String
Dim DestWB As Workbook
Dim ws As Object 'Рабочие листы могут быть произвольного типа.

Const DirLoc As String = "C:\УЗК\" 'Местоположение исходных файлов.
Const DirLoc1 As String = "C:\УЗК_ОБЩ\" 'Местоположение конечного файла.

Application.ScreenUpdating = False

Set DestWB = Workbooks.Add(xlWorksheet)
CurFile = Dir(DirLoc & "*.xlsx")

Do While CurFile <> vbNullString

Dim OrigWB As Workbook
Set OrigWB = Workbooks.Open(FileName:=DirLoc & CurFile, _
ReadOnly:=True)
CurFile = Left(Left(CurFile, Len(CurFile) - 4), 29)

'Получение базового имени
'рабочего листа путем отсечения
'последних 4-х символов имени
'исходного файла (".xlsx").

For Each ws In OrigWB.Sheets
ws.Copy After:=DestWB.Sheets(DestWB.Sheets.Count)

If OrigWB.Sheets.Count > 1 Then
DestWB.Sheets(DestWB.Sheets.Count).Name = CurFile & ws.Index
Else
DestWB.Sheets(DestWB.Sheets.Count).Name = CurFile
End If

Next

OrigWB.Close SaveChanges:=False
CurFile = Dir

Loop

FinalFileName = DirLoc1 & "Общ_УЗК" & ".xlsx"

ActiveWorkbook.SaveAs FileName:=FinalFileName, _
FileFormat:=xlWorkbookDefault

Application.DisplayAlerts = False
DestWB.Sheets(1).Delete
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Set DestWB = Nothing

'Application.DisplayAlerts = True

End Sub

Sub RemovingTempFiles()
Dim fso As Object

Set fso = CreateObject("Scripting.FileSystemObject")

fso.DeleteFolder ("C:\УЗК")
fso.DeleteFolder ("C:\УЗК_ОБЩ")

End Sub
[/vba]


Сообщение отредактировал Alexey_1979 - Суббота, 16.01.2021, 06:48
 
Ответить
Сообщение[vba]
Код
Sub Get_All_File_from_Folder()
Dim sFolder As String, sFiles As String
Dim wb As Workbook
Dim fso As Object, foldr As Object, foldr1 As Object

Set fso = CreateObject("Scripting.FileSystemObject")

If fso.FolderExists("C:\УЗК") Or fso.FolderExists("C:\УЗК_ОБЩ") Then

Call RemovingTempFiles

Path0 = "C:\УЗК"
Path1 = "C:\УЗК_ОБЩ"
fso.CreateFolder Path0
fso.CreateFolder Path1

Else

Path0 = "C:\УЗК"
Path1 = "C:\УЗК_ОБЩ"
fso.CreateFolder Path0
fso.CreateFolder Path1

End If

Set foldr = fso.getfolder(Path0)
Set foldr1 = fso.getfolder(Path1)

'диалог запроса выбора папки с файлами
With Application.FileDialog(msoFileDialogFolderPicker)
If .Show = False Then Exit Sub
sFolder = .SelectedItems(1)
End With
sFolder = sFolder & IIf(Right(sFolder, 1) = Application.PathSeparator, "", Application.PathSeparator)

Application.ScreenUpdating = False
sFiles = Dir(sFolder & "Зак*.xls*")
Do While sFiles <> ""
'открываем книгу
Set wb = Application.Workbooks.Open(sFolder & sFiles)
'действия с файлом
FileName = Path0 & "\" & wb.Sheets("УК").Cells(3, 12) & "-" & wb.Sheets("УК").Cells(3, 13) _
& "-" & wb.Sheets("УК").Cells(3, 14) & ".xlsx"

Err.Clear: wb.Sheets("УК").Copy: DoEvents

arr = wb.Sheets("УК").UsedRange.Value

ActiveSheet.Buttons.Delete
Range("A1:R25").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False

Range("T7:U15").Select
Selection.ClearContents

Range("J27:P33").Select
Selection.EntireRow.Delete

Range("A1").Select

If Err Then Exit Sub

If ActiveWorkbook.Worksheets.Count = 1 And ActiveWorkbook.Path = "" Then

Application.DisplayAlerts = False
ActiveWorkbook.SaveAs FileName, xlOpenXMLWorkbook
ActiveWorkbook.Close True

End If

'Закрываем книгу с сохранением изменений
wb.Close False 'если поставить False - книга будет закрыта без сохранения
sFiles = Dir
Loop

Call MergingFiles

Application.ScreenUpdating = True

End Sub

Sub MergingFiles()
' Собираем все листы в новую книгу с именем ТП

Application.DisplayAlerts = False

Dim CurFile As String
Dim DestWB As Workbook
Dim ws As Object 'Рабочие листы могут быть произвольного типа.

Const DirLoc As String = "C:\УЗК\" 'Местоположение исходных файлов.
Const DirLoc1 As String = "C:\УЗК_ОБЩ\" 'Местоположение конечного файла.

Application.ScreenUpdating = False

Set DestWB = Workbooks.Add(xlWorksheet)
CurFile = Dir(DirLoc & "*.xlsx")

Do While CurFile <> vbNullString

Dim OrigWB As Workbook
Set OrigWB = Workbooks.Open(FileName:=DirLoc & CurFile, _
ReadOnly:=True)
CurFile = Left(Left(CurFile, Len(CurFile) - 4), 29)

'Получение базового имени
'рабочего листа путем отсечения
'последних 4-х символов имени
'исходного файла (".xlsx").

For Each ws In OrigWB.Sheets
ws.Copy After:=DestWB.Sheets(DestWB.Sheets.Count)

If OrigWB.Sheets.Count > 1 Then
DestWB.Sheets(DestWB.Sheets.Count).Name = CurFile & ws.Index
Else
DestWB.Sheets(DestWB.Sheets.Count).Name = CurFile
End If

Next

OrigWB.Close SaveChanges:=False
CurFile = Dir

Loop

FinalFileName = DirLoc1 & "Общ_УЗК" & ".xlsx"

ActiveWorkbook.SaveAs FileName:=FinalFileName, _
FileFormat:=xlWorkbookDefault

Application.DisplayAlerts = False
DestWB.Sheets(1).Delete
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Set DestWB = Nothing

'Application.DisplayAlerts = True

End Sub

Sub RemovingTempFiles()
Dim fso As Object

Set fso = CreateObject("Scripting.FileSystemObject")

fso.DeleteFolder ("C:\УЗК")
fso.DeleteFolder ("C:\УЗК_ОБЩ")

End Sub
[/vba]

Автор - Alexey_1979
Дата добавления - 16.01.2021 в 06:41
Alexey_1979 Дата: Суббота, 16.01.2021, 07:10 | Сообщение № 8
Группа: Пользователи
Ранг: Прохожий
Сообщений: 8
Репутация: 0 ±
Замечаний: 0% ±

Excel 2019
Елена, прошу прощения что долго не отвечал. Выложил код VBA.


Сообщение отредактировал Alexey_1979 - Суббота, 16.01.2021, 07:13
 
Ответить
СообщениеЕлена, прошу прощения что долго не отвечал. Выложил код VBA.

Автор - Alexey_1979
Дата добавления - 16.01.2021 в 07:10
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Сохранение листа с заданным именем в отдельный файл. (Макросы/Sub)
  • Страница 1 из 1
  • 1
Поиск:

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