Профессиональные приемы работы в Microsoft Excel

Пожалуйста, войдите или зарегистрируйтесь.


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

Новости:

Читайте новые сообщения форума форума в RRS-агрегаторах

Автор Тема: Макрос создания книги при условии, что такой еще нет  (Прочитано 371 раз)

0 Пользователей и 1 Гость просматривают эту тему.

Honey

  • Новичок
  • *
  • Уважение: +0/-0
  • Оффлайн Оффлайн
  • Сообщений: 4

Всем добрый вечер!

Прошу помочь мне разобраться с такой проблемкой... Есть макрос, который создает определенную книгу, с определенным названием в определенную папку. Я пыталась прописать условие: если такой книги нет-создавай, если уже есть такая- ее открой.
В коде ниже есть такое условие для папки, которая тоже создается макросом. Только папка не открывается при несоблюдении условия, а просто само задание игнорируется. А вот с книгой пошло все не так...
Код:
Sub Main()
     
    Const strRootFolder As String = "M:\Production\Мастера\2017\Нормализация"
     
    Dim strFolder As String
     
    strFolder = "M:\Production\Мастера\2017\Нормализация\" & Range("имя_папки").Value
     
    If Dir(strFolder, vbDirectory) = "" Then
        MkDir strFolder
    End If
     
    Dim New_Wb As Workbook
    Set New_Wb = Workbooks.Add
    New_Wb.Activate
    New_Wb.SaveAs "M:\Production\Мастера\2017\Нормализация\" & Workbooks("Расчет.xlsm").Worksheets("1 норм").Range("имя_папки").Value & "\" & Workbooks("Расчет.xlsm").Worksheets("1 норм").Range("Книга") & ".xlsm", 52
   
    If Dir(New_Wb, vbDirectory) = "" Then
        MkDir New_Wb
    End If
   
   Windows("Расчет.xlsm").Activate
     
End Sub
Также в приложении сам файл-пример.

Всем спасибо заранее за любую идею и помощь! :)
« Последнее редактирование: 21.06.2017, 14:22:02 от vikttur »
Записан

Pelena

  • Постоялец
  • ***
  • Уважение: +35/-0
  • Оффлайн Оффлайн
  • Сообщений: 273

Здравствуйте.
Может быть, просмотреть все файлы в папке и сравнить имя каждого с искомым. Если нашли, то открыть, иначе создать
Записан

Honey

  • Новичок
  • *
  • Уважение: +0/-0
  • Оффлайн Оффлайн
  • Сообщений: 4

Добрый день!

Спасибо за идею и за ссылку)))
Только я вот не особо разбираюсь в макросах. Пробовала вставить не получилось. В кукую строку конкретно нужно вставить? Вместо If Dir(New_Wb, vbDirectory) = "" Then
        MkDir New_Wb
    End If
И только часть Dim sFolder As String, sFiles As String
    'диалог запроса выбора папки с файлами
    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 <> ""
        'открываем книгу
        Workbooks.Open sFolder & sFiles
А куда далее прописать что если нет такого файла, то создай как описано в моем коде выше?

Спасибо за ответ! :)
Записан

Honey

  • Новичок
  • *
  • Уважение: +0/-0
  • Оффлайн Оффлайн
  • Сообщений: 4

Еще нашла другой код и получилось:
Sub Main()
     
    Const strRootFolder As String = "M:\Production\Masters\2017\Normalization
   
    Dim strFolder As String
   
    strFolder = "M:\Production\Masters\2017\Normalization\" & Range("folder_name").Value
   
    If Dir(strFolder, vbDirectory) = "" Then
        MkDir strFolder
    End If
   
 Dim New_Wb As Workbook
    Set New_Wb = Workbooks.Add
    New_Wb.Activate
    New_Wb.SaveAs "M:\Production\Masters\2017\Normalization\" & Workbooks("Расчет.xlsm").Worksheets("1").Range("folder_name").Value & "\" & Workbooks("Расчет.xlsm").Worksheets("1").Range("Book") & ".xlsm", 52
   
    Папка = "M:\Production\Masters\2017\Normalization\" & Workbooks("Расчет.xlsm").Worksheets("1").Range("folder_name").Value & "\"
Имя = Dir(Папка & "*.xls*")
Do While Имя <> ""
If Имя <> "M:\Production\Masters\2017\Normalization\" & Workbooks("Расчет.xlsm").Worksheets("1").Range("folder_name").Value & "\" & Workbooks("Расчет.xlsm").Worksheets("1").Range("Book") & ".xlsm" Then MkDir New_Wb Else Workbooks.Open Filename:="M:\Production\Masters\2017\Normalization\" & Workbooks("Расчет.xlsm").Worksheets("1").Range("folder_name").Value & "\" & Workbooks("Расчет.xlsm").Worksheets("1").Range("Book") & ".xlsm"
Имя = Dir
Loop
   
   Windows("Расчет.xlsm").Activate
   
End Sub

Но все-равно спрашивает заменить уже существующий файл или нет...(((
Записан

Honey

  • Новичок
  • *
  • Уважение: +0/-0
  • Оффлайн Оффлайн
  • Сообщений: 4

Решение:
Sub Main()
     
    Const strRootFolder As String = "M:\Production\Мастера\2017\Нормализация"
   
    Dim strFolder As String
   
    strFolder = "M:\Production\Мастера\2017\Нормализация\" & Range("имя_папки").Value
   
    If Dir(strFolder, vbDirectory) = "" Then
        MkDir strFolder
    End If
   
     Dim strFileName As String

   Dim strFileTitle As String

   ' Имя и путь искомого файла

   strFileTitle = "M:\Production\Мастера\2017\Нормализация\" & Workbooks("Расчет нормализации для Шымкента.xlsm").Worksheets("1 норм").Range("имя_папки").Value & "\" & Workbooks("Расчет нормализации для Шымкента.xlsm").Worksheets("1 норм").Range("Книга") & ".xlsm"

   strFileName = "M:\Production\Мастера\2017\Нормализация\" & Workbooks("Расчет нормализации для Шымкента.xlsm").Worksheets("1 норм").Range("имя_папки").Value & "\" & Workbooks("Расчет нормализации для Шымкента.xlsm").Worksheets("1 норм").Range("Книга") & ".xlsm"

   ' Проверка наличия файла (функция Dir возвращает пустую _
   строку, если по указанному пути файл обнаружить не удалось)

   If Dir(strFileName) <> "" Then

      MsgBox "OK"

   Else

 Dim New_Wb As Workbook
    Set New_Wb = Workbooks.Add
    New_Wb.Activate
    New_Wb.SaveAs "M:\Production\Мастера\2017\Нормализация\" & Workbooks("Расчет нормализации для Шымкента.xlsm").Worksheets("1 норм").Range("имя_папки").Value & "\" & Workbooks("Расчет нормализации для Шымкента.xlsm").Worksheets("1 норм").Range("Книга") & ".xlsm", 52
    End If
   
   Windows("Расчет нормализации для Шымкента.xlsm").Activate
   
End Sub
Записан

kuklp1

  • Пользователь
  • **
  • Уважение: +5/-0
  • Оффлайн Оффлайн
  • Сообщений: 82

А так?
Sub www()
    Dim New_Wb As Workbook, s$
    CreateObject("Shell.Application").Namespace("m:\").NewFolder ("Production\Мастера\2017\Нормализация\" & Range("имя_папки").Value)
    s = "m:\Production\Мастера\2017\Нормализация\" & Range("имя_папки").Value & "\" & Range("Книга") & ".xlsm"
    If Dir(s) <> "" Then Exit Sub
    Set New_Wb = Workbooks.Add
    New_Wb.SaveAs s, 52
End Sub
Записан
Я, как всегда, чертовски адекватен… Email: kuklp60@gmail.com WM Z206653985942, R334086032478, U238399322728, E332314026771
 



Темы без ответов

06.09.2017 10:43 Solver VBA не решает гиперболическое уравнение, но при этом решает гармоническое 104
17.08.2017 12:15 Гиперссылка и фильтр одновременно макрос 222
13.06.2017 00:27 Сводная таблица: как не вручную отсортировать в опред. порядке (не Custom List) 623
23.05.2017 11:20 Копирование данных из одной таблицы в умную таблицу по условию 1081
18.05.2017 15:45 Не работает гиперссылка при копировании. 592
15.03.2017 15:45 автозамена картинок PowerPoint 835
13.03.2017 07:09 Использование базы КЛАДР в exel 1183
11.03.2017 13:43 Изменить нумерацию страниц 1059
10.03.2017 08:40 Как делать бекапы гугл таблицы? 900
18.02.2017 11:31 Изменить ввод данных помогите...из столбца в таблицу. 1132





Яндекс цитирования msexcel.ru Яндекс.Метрика

Страница сгенерирована за 0.108 секунд. Запросов: 36.