Форум программистов
 

Восстановите пароль или Зарегистрируйтесь на форуме, о проблемах и с заказом рекламы пишите сюда - alarforum@yandex.ru, проверяйте папку спам!

Вернуться   Форум программистов > Microsoft Office и VBA программирование > Microsoft Office Excel
Регистрация

Восстановить пароль
Повторная активизация e-mail

Купить рекламу на форуме - 42 тыс руб за месяц

Закрытая тема
Ваша тема закрыта, почему это могло произойти? Возможно,
Нет наработок или кода, если нужно готовое решение - создайте тему в разделе Фриланс и оплатите работу.
Название темы включает слова - "Помогите", "Нужна помощь", "Срочно", "Пожалуйста".
Название темы слишком короткое или не отражает сути вашего вопроса.
Тема исчерпала себя, помните, один вопрос - одна тема
Прочитайте правила и заново правильно создайте тему.
 
Опции темы Поиск в этой теме
Старый 13.08.2009, 23:35   #1
xamillion
Форумчанин
 
Аватар для xamillion
 
Регистрация: 30.09.2008
Сообщений: 138
По умолчанию переименование файлов в папке макросом из Excel

Что имеем:
- много файлов excel, полученных по запросу из браузера, с беспорядочными названиями...

Что нужно:
- переименовать эти файлы именем, находящееся в 2-х ячейках, т.е. в ячейке A2 первая часть названия файла, а в ячейке A8 - вторая часть... точнее из ячейки A2 взять первые буквы слов, а из A8 взять из набора слов первую дату предварительно переведя ее в буквеное выражение...
файлов может быть очень много!!!

Звучит сложно, по крайней мере, для меня...
Вложения
Тип файла: rar пример.rar (12.7 Кб, 194 просмотров)
xamillion вне форума
Старый 14.08.2009, 01:16   #2
EducatedFool
Программист VBA
СуперМодератор
 
Аватар для EducatedFool
 
Регистрация: 13.07.2008
Сообщений: 6,856
По умолчанию

Посмотрите универсальную надстройку для переименования файлов в папке:
http://excelvba.ru/programmes/RenameFiles



Цитата:
файлов может быть очень много!!!
Насколько много?
Сотни, тысячи, десятки тысяч?
Все ли эти файлы находятся в одной папке? (или имеется древовидная структура папок - файлы надо искать и во вложенных папках)

Цитата:
а из A8 взять из набора слов первую дату предварительно переведя ее в буквеное выражение
Что делать, если значение в A8 не является датой?
И вообще, с какого листа брать данные?
С первого или с последнего?
Известно заранее имя листа?

Последний раз редактировалось EducatedFool; 21.09.2015 в 04:49.
EducatedFool вне форума
Старый 14.08.2009, 21:45   #3
xamillion
Форумчанин
 
Аватар для xamillion
 
Регистрация: 30.09.2008
Сообщений: 138
По умолчанию

Цитата:
Насколько много?
Сотни, тысячи, десятки тысяч?
Все ли эти файлы находятся в одной папке? (или имеется древовидная структура папок - файлы надо искать и во вложенных папках)
файлов больше 200-300 штук не должно быть... лежат они все в одной папке... во вложениях соответственно искать не надо...

Цитата:
Что делать, если значение в A8 не является датой?
там дата во втором слове (в примере видно), во всех файлах одинаково...

Цитата:
И вообще, с какого листа брать данные?
С первого или с последнего?
лист всего один будет в книге....

Цитата:
Известно заранее имя листа?
Имя заранее неизвестно, но скорее всего будет называться как сам файл до переименования...
xamillion вне форума
Старый 15.08.2009, 11:00   #4
EducatedFool
Программист VBA
СуперМодератор
 
Аватар для EducatedFool
 
Регистрация: 13.07.2008
Сообщений: 6,856
По умолчанию

Вот весь код:
Код:
Sub Main()
    Dim SourceFolder As String, DestinationFolder As String, ce As Range
    InitialPath = ThisWorkbook.Path: Dim coll As New Collection
    Application.ScreenUpdating = False

    SourceFolder = GetFolderPath("Выберите исходную папку для поиска файлов", InitialPath)
    If SourceFolder = "" Then MsgBox "Необходимо указать папку!", vbCritical, "Папка не выбрана": Exit Sub

    DestinationFolder = GetFolderPath("Выберите папку, в которую будет производиться копирование", SourceFolder)
    If DestinationFolder = "" Then MsgBox "Необходимо указать папку!", vbCritical, "Папка не выбрана": Exit Sub

    On Error Resume Next
    If Dir(DestinationFolder, vbDirectory) = "" Then MkDir DestinationFolder    ' если конечная папка не существует, создаём её

    Filename = Dir(SourceFolder & "*.xls")
    Dim wb As Workbook, sh As Worksheet
    While Filename <> ""
        coll.Add Filename: Filename = Dir
    Wend

    For Each file In coll
        Set wb = Workbooks.Open(SourceFolder & file, , True)
        Application.StatusBar = "Обрабатывается файл  " & file    ' вывод информации в строку состояния
        Set sh = wb.Worksheets(3) ' замените на Set sh = wb.Worksheets(1)
        NewFilename = НовоеИмяФайла(sh.Cells(2, 1), sh.Cells(8, 1))
        wb.SaveAs DestinationFolder & NewFilename
        wb.Close False
    Next

    Application.StatusBar = ""
End Sub

Function НовоеИмяФайла(ByVal cell2 As String, ByVal cell8 As String) As String
    '    cell2 = "Наименование товара я-эмульгатор"
    '    cell8 = "Расфасовано 30.08.2009 партия 12.04.2008"
    '    НовоеИмяФайла = "НТЯ август 2009.xls"

    arr = Split(cell2, " ")
    For i = LBound(arr) To UBound(arr)
        НовоеИмяФайла = НовоеИмяФайла & Left(arr(i), 1)
    Next
    НовоеИмяФайла = UCase(НовоеИмяФайла)

    дата = Split(cell8, " ")(1)
    If IsDate(дата) Then НовоеИмяФайла = НовоеИмяФайла & " " & LCase(Format(дата, "MMMM YYYY"))
    НовоеИмяФайла = НовоеИмяФайла & ".xls"
End Function

Function GetFolderPath(Optional ByVal Title As String = "Выберите папку", Optional ByVal InitialPath As String = "c:\") As String
    GetFolderPath = "": PS = Application.PathSeparator
    With Application.FileDialog(msoFileDialogFolderPicker)
        .ButtonName = "Выбрать": .Title = Title: .InitialFileName = InitialPath
        If .Show = -1 Then GetFolderPath = .SelectedItems(1): If Not Right$(GetFolderPath, 1) = PS Then GetFolderPath = GetFolderPath & PS
    End With
End Function
EducatedFool вне форума
Старый 15.08.2009, 12:27   #5
xamillion
Форумчанин
 
Аватар для xamillion
 
Регистрация: 30.09.2008
Сообщений: 138
По умолчанию

Спасибо... работает отлично... а можно поместиь в ту же папку файлы с новыми названиями вместо старых (старые удалить)?... пробую учиться сам, но пока не все получается...
xamillion вне форума
Старый 15.08.2009, 13:05   #6
EducatedFool
Программист VBA
СуперМодератор
 
Аватар для EducatedFool
 
Регистрация: 13.07.2008
Сообщений: 6,856
По умолчанию

Попробуйте так: (удаление исходного файла)
Код:
Sub Main()
    Dim SourceFolder As String, DestinationFolder As String, ce As Range
    InitialPath = ThisWorkbook.Path: Application.ScreenUpdating = False

    SourceFolder = GetFolderPath("Выберите исходную папку для поиска файлов", InitialPath)
    If SourceFolder = "" Then MsgBox "Необходимо указать папку!", vbCritical, "Папка не выбрана": Exit Sub

    On Error Resume Next
    Filename = Dir(SourceFolder & "*.xls")
    Dim wb As Workbook, sh As Worksheet, coll As New Collection
    While Filename <> "": coll.Add Filename: Filename = Dir: Wend

    For Each file In coll
        Set wb = Workbooks.Open(SourceFolder & file, , True)
        Application.StatusBar = "Обрабатывается файл  " & file    ' вывод информации в строку состояния
        Set sh = wb.Worksheets(3)    ' замените на Set sh = wb.Worksheets(1)
        NewFilename = НовоеИмяФайла(sh.Cells(2, 1), sh.Cells(8, 1))
        wb.SaveAs DestinationFolder & NewFilename
        wb.Close False
        Kill SourceFolder & file
    Next
    Application.StatusBar = "": Application.ScreenUpdating = True
End Sub

Или так: (переименование исходного файла, должно работать быстрее предыдущего способа)
Код:
Sub Main()
    Dim SourceFolder As String, DestinationFolder As String, ce As Range
    InitialPath = ThisWorkbook.Path: Application.ScreenUpdating = False

    SourceFolder = GetFolderPath("Выберите исходную папку для поиска файлов", InitialPath)
    If SourceFolder = "" Then MsgBox "Необходимо указать папку!", vbCritical, "Папка не выбрана": Exit Sub

    On Error Resume Next
    Filename = Dir(SourceFolder & "*.xls")
    Dim wb As Workbook, sh As Worksheet, coll As New Collection
    While Filename <> "": coll.Add Filename: Filename = Dir: Wend

    For Each file In coll
        Application.StatusBar = "Обрабатывается файл  " & file    ' вывод информации в строку состояния
        Set wb = Workbooks.Open(SourceFolder & file, , True)
        Set sh = wb.Worksheets(3)    ' замените на Set sh = wb.Worksheets(1)
        NewFilename = НовоеИмяФайла(sh.Cells(2, 1), sh.Cells(8, 1))
        wb.Close False
        Name SourceFolder & file As SourceFolder & NewFilename
    Next
    Application.StatusBar = "": Application.ScreenUpdating = True
End Sub
EducatedFool вне форума
Старый 15.08.2009, 18:13   #7
xamillion
Форумчанин
 
Аватар для xamillion
 
Регистрация: 30.09.2008
Сообщений: 138
Хорошо

и снова спасибо... теперь именно так как нужно...
xamillion вне форума
Старый 10.11.2009, 16:49   #8
xamillion
Форумчанин
 
Аватар для xamillion
 
Регистрация: 30.09.2008
Сообщений: 138
По умолчанию

Возник еще вопрос:
что добавить в код, чтобы к названию прибавилось все содержимое ячейки A4 (здесь хранится название предприятия, присутствуют ковычки"", они не допустимы в названии файлов...):
If IsDate(дата) Then НовоеИмяФайла = НовоеИмяФайла & " " & LCase(Format(дата, "MMMM YYYY"))
xamillion вне форума
Старый 10.11.2009, 16:57   #9
EducatedFool
Программист VBA
СуперМодератор
 
Аватар для EducatedFool
 
Регистрация: 13.07.2008
Сообщений: 6,856
По умолчанию

Код:
    Предприятие = Replace([a4], """", "'")    ' заменяем двойные кавычки одинарными '
    If IsDate(дата) Then НовоеИмяФайла = Предприятие & " " & НовоеИмяФайла & _
       " " & LCase(Format(дата, "MMMM YYYY"))
EducatedFool вне форума
Старый 10.11.2009, 17:24   #10
xamillion
Форумчанин
 
Аватар для xamillion
 
Регистрация: 30.09.2008
Сообщений: 138
По умолчанию

Цитата:
Сообщение от EducatedFool Посмотреть сообщение
Код:
    Предприятие = Replace([a4], """", "'")    ' заменяем двойные кавычки одинарными '
    If IsDate(дата) Then НовоеИмяФайла = Предприятие & " " & НовоеИмяФайла & _
       " " & LCase(Format(дата, "MMMM YYYY"))
АФИГЕТЬ!!!
А ламером то хреново быть... Хотел сам - пол дня вертел... )))
Спасибо приспасибущее...
xamillion вне форума
Закрытая тема


Купить рекламу на форуме - 42 тыс руб за месяц

Опции темы Поиск в этой теме
Поиск в этой теме:

Расширенный поиск


Похожие темы
Тема Автор Раздел Ответов Последнее сообщение
Формирование списка файлов в папке на листе. mephist Microsoft Office Excel 3 12.08.2009 17:59
Переименование группы файлов Meh Общие вопросы Delphi 2 28.07.2009 12:31
Как сделать поиск файлов в папке BETONOMESHALKA Общие вопросы Delphi 3 01.02.2008 22:43
Просмотр файлов в папке и подпапках Yar Помощь студентам 9 07.08.2007 16:56