On Error Resume Next
     Set FSO = CreateObject("scripting.filesystemobject")
     ' создаём главную папку
     BaseFolder$ = "C:\Sewage\": MkDir BaseFolder$
     MkDir BaseFolder$
     ' создаём подпапку
     BaseFolder$ = "C:\Sewage\line" & Range("B1").Value & "\": MkDir BaseFolder$
     MkDir BaseFolder$
      
     ' проверка на существование файла
     If Dir(BaseFolder$ & "line" & Range("B1").Value & ".collectin") > "" Then
          
     Dim iRet As Integer
     Dim strPrompt As String
     Dim strTitle As String
   
     ' Promt
     strPrompt = "Файл уже существует! Перезаписать?"
   
     ' Dialog's Title
     strTitle = "Ошибка!"
   
     'Display MessageBox
     iRet = MsgBox(strPrompt, vbYesNo, strTitle)
   
     ' Check pressed button
     If iRet = vbNo Then
         MsgBox "Сохранение отменено!"
     Else
         MsgBox "Файл перезаписан!"
     ' создаём текстовый файл в кодировке Unicode
     Set ts = FSO.CreateTextFile(BaseFolder$ & "line" & Range("B1").Value & ".collectin", True)
     ts.Close
     ' заполняем его данными
     Open "C:\Sewage\line" & Range("B1").Value & "\" & "line" & Range("B1").Value & ".collectin" For Output As #1
                     Range("1:1048576").Copy
                     With New DataObject
                         .GetFromClipboard
                         Print #1, Replace(.GetText(1), vbTab, "|")
                     End With
                     Application.CutCopyMode = False
                 Close #1
           MsgBox "Файл создан и помещен в папку" & vbNewLine & BaseFolder$, vbInformation, "Готово"
     ' открываем папку с файлом
     CreateObject("wscript.shell").Run "explorer.exe /e, """ & BaseFolder$ & """"
     End If
      
     Else
     ' создаём текстовый файл в кодировке Unicode
     Set ts = FSO.CreateTextFile(BaseFolder$ & "line" & Range("B1").Value & ".collectin", True)
     ts.Close
     ' заполняем его данными
     Open "C:\Sewage\line" & Range("B1").Value & "\" & "line" & Range("B1").Value & ".collectin" For Output As #1
                     Range("1:1048576").Copy
                     With New DataObject
                         .GetFromClipboard
                         Print #1, Replace(.GetText(1), vbTab, "|")
                     End With
                     Application.CutCopyMode = False
                 Close #1
           MsgBox "Файл создан и помещен в папку" & vbNewLine & BaseFolder$, vbInformation, "Готово"
     ' открываем папку с файлом
     CreateObject("wscript.shell").Run "explorer.exe /e, """ & BaseFolder$ & """"
     End If