Новости:

Теперь на форум можно залогиниться / зарегистрироваться с помощью ВКонтакте. Уже существующие пользователи могут связать свою учетную запись с аккаунтом ВКонтакте одним кликом в профиле пользователя http://forum.msexcel.ru/index.php?action=profile;area=account

Главное меню

Макрос создания книги при условии, что такой еще нет

Автор Honey, 21.06.2017, 13:58

« назад - далее »

Honey

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

Прошу помочь мне разобраться с такой проблемкой... Есть макрос, который создает определенную книгу, с определенным названием в определенную папку. Я пыталась прописать условие: если такой книги нет-создавай, если уже есть такая- ее открой.
В коде ниже есть такое условие для папки, которая тоже создается макросом. Только папка не открывается при несоблюдении условия, а просто само задание игнорируется. А вот с книгой пошло все не так...
Код:
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
Также в приложении сам файл-пример.

Всем спасибо заранее за любую идею и помощь! :)

Pelena

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

Honey

Добрый день!

Спасибо за идею и за ссылку)))
Только я вот не особо разбираюсь в макросах. Пробовала вставить не получилось. В кукую строку конкретно нужно вставить? Вместо 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

Еще нашла другой код и получилось:
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

Решение:
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

А так?
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