Сохранение файлов именем ячейки в цикле.

[AJIEXEY]

Добрый день, уважаемые программисты.
Подскажите, пожалуйста, вот есть у меня макрос:

Sub Отчет()

i = 2
n = Лист3.Cells(11, 3).Value
s = 1


While Лист4.Cells(i, 1).Value <> "" 'бежим по списку ФИО приставов
j = 2
k = 4
Sheets("Формируемый отчет").Select
Cells.Select
Selection.ClearContents
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
Selection.Borders(xlEdgeLeft).LineStyle = xlNone
Selection.Borders(xlEdgeTop).LineStyle = xlNone
Selection.Borders(xlEdgeBottom).LineStyle = xlNone
Selection.Borders(xlEdgeRight).LineStyle = xlNone
Selection.Borders(xlInsideVertical).LineStyle = xlNone
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
While Лист1.Cells(j, 12).Value <> "" 'бежим по списку исходника
If Лист1.Cells(j, 1).Value = Лист4.Cells(i, 1).Value And Лист1.Cells(j, 2).Value = Лист4.Cells(i, 2).Value Then
Лист2.Cells(1, 1).Value = Лист1.Cells(j, 1).Value 'прописываем орган ФССП
Лист2.Cells(2, 1).Value = Лист1.Cells(j, 2).Value 'прописываем адрес ФССП

For q = 3 To 13 'прописываем все совпадения

'совпадения'
Лист2.Cells(k, q - 2).Value = Лист1.Cells(j, q).Value

Next q
k = k + 1

End If

j = j + 1
Wend
For q = 3 To 13
'шапка'
Лист2.Cells(3, q - 2).Value = Лист1.Cells(1, q).Value
Range(Лист2.Cells(3, 1), Лист2.Cells(3, 11)).Borders.Weight = 2
Range(Лист2.Cells(3, 1), Лист2.Cells(3, 11)).Select
Selection.WrapText = True
Next q
'совпадения'
Range(Лист2.Cells(4, 1), Лист2.Cells(k, 11)).Borders.Weight = 2
Range(Лист2.Cells(4, 1), Лист2.Cells(k, 11)).Select
Selection.WrapText = True
If Лист2.Cells(1, 1).Value <> "" Then 'заполняем сопроводиловку
Лист3.Cells(11, 3).Value = n
Лист3.Cells(12, 5).Value = Лист2.Cells(1, 1).Value
Лист3.Cells(13, 5).Value = Лист2.Cells(2, 1).Value
If ((Лист2.HPageBreaks.Count + 1) / 2) <> Fix((Лист2.HPageBreaks.Count + 1) / 2) Then
Лист3.Cells(20, 3).Value = Fix((Лист2.HPageBreaks.Count + 1) / 2) + 1
Else
Лист3.Cells(20, 3).Value = (Fix((Лист2.HPageBreaks.Count + 1) / 2))
End If
Sheets("Формируемая сопроводиловка").Select
ExecuteExcel4Macro "PRINT(1,,,1,,,,,,,,2,,,TRUE,,FALSE)"
Sheets("Формируемый отчет").Select
ExecuteExcel4Macro "PRINT(1,,,1,,,,,,,,2,,,TRUE,,FALSE)"
n = n + 1
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs [a1]
Application.DisplayAlerts = True
Лист5.Cells(s, 1).Value = "Отчет в " + Лист2.Cells(1, 1).Value 'прописываем орган ФССП
Лист5.Cells(s, 2).Value = "УФССП" 'прописываем куда
Лист5.Cells(s, 3).Value = "Гудовских Е.А." 'прописываем кто подписал
s = s + 1
End If
i = i + 1
Wend
Application.DisplayAlerts = False
Sheets("Исходник").Select
ActiveWindow.SelectedSheets.Delete
Sheets("ФИО пристава").Select
ActiveWindow.SelectedSheets.Delete
Sheets("список для регистрации").Select
ActiveWindow.SelectedSheets.Delete
Sheets("Для отдельных").Select
ActiveWindow.SelectedSheets.Delete
Range("R12").Select
End Sub

По этому макросу создаются сопроводительные письма и отправляются на печать. А потом каждое сопроводительное письмо я сохраняю в Excel в электронном формате. Хотелось бы в макрос добавить цикл, который будет сохранять каждое сопроводительное письмо под именем, содержащимся в ячейке и удалять ненужные листы, а точнее хотелось бы после того как формировывается и отправляется на печать, каждое сопроводительное письмо оно сохранялось именем ячейки ('Формируемая сопроводиловка'!E12:I12) в сопроводиловке + дата создания файла.

Sheets("Формируемая сопроводиловка").Select
ExecuteExcel4Macro "PRINT(1,,,1,,,,,,,,2,,,TRUE,,FALSE)"
Sheets("Формируемый отчет").Select
ExecuteExcel4Macro "PRINT(1,,,1,,,,,,,,2,,,TRUE,,FALSE)"
n = n + 1
Лист5.Cells(s, 1).Value = "Отчет в " + Лист2.Cells(1, 1).Value 'прописываем орган ФССП
Лист5.Cells(s, 2).Value = "УФССП" 'прописываем куда
Лист5.Cells(s, 3).Value = "Гудовских Е.А." 'прописываем кто подписал
s = s + 1
End If
i = i + 1

Я как понимаю должно быть где-то тут написано, но вот как и точно где не могу понять

Очень прошу, подскажите. Заколебался каждую сопроводиловку сохранять по отдельности, а их каждое утро набирается по 100 шт.




___________
Код нужно оформлять по правилам:
тегом [CODE]..[/СODE]
(кнопочка на панели форматирования с решёточкой #)
Не забывайте об этом!

Модератор.

[DiemonStar]

выкладывайте пример файла. без примера только догадываться, а это влом...

[AJIEXEY]

Отчет.rar
Помогите, пожалуйста

[DiemonStar]

Хотелось бы в макрос добавить цикл, который будет сохранять каждое сопроводительное письмо под именем, содержащимся в ячейке и удалять ненужные листы, а точнее хотелось бы после того как формировывается и отправляется на печать, каждое сопроводительное письмо оно сохранялось именем ячейки ('Формируемая сопроводиловка'!E12:I12) в сопроводиловке + дата создания файла.

в какой ячейке он будет содержаться? или вы планируете в исходном файле сделать список сохраненных сопроводиловок?

[DiemonStar]

Function dhReplaceAll( _
ByVal strText As String, _
ByVal strFind As String, _
ByVal strReplace As String) As String

чем вас не устроила обычная формула Replace?

попробуйте такой код:

Sub Отчет()
  Application.ScreenUpdating = False
  I = 2
  n = Лист3.Cells(11, 3).Value
  Set WB = ThisWorkbook
  While Лист4.Cells(I, 1).Value <> ""                                 'бежим по списку ФИО приставов
    With Лист2.Cells
      .ClearContents
      .Borders(xlDiagonalDown).LineStyle = xlNone
      .Borders(xlDiagonalUp).LineStyle = xlNone
      .Borders(xlEdgeLeft).LineStyle = xlNone
      .Borders(xlEdgeTop).LineStyle = xlNone
      .Borders(xlEdgeBottom).LineStyle = xlNone
      .Borders(xlEdgeRight).LineStyle = xlNone
      .Borders(xlInsideVertical).LineStyle = xlNone
      .Borders(xlInsideHorizontal).LineStyle = xlNone
    End With
    
    Лист1.[A:N].AutoFilter Field:=1, Criteria1:=Лист4.Range("A" & I)
    Лист1.[A:N].AutoFilter Field:=2, Criteria1:=Лист4.Range("B" & I)
    Intersect(Лист1.[A:N].SpecialCells(xlCellTypeVisible), _
              Лист1.[C:N], _
              Лист1.Range("$1:$" & Лист1.Range("A" & Лист1.Rows.Count).End(xlUp).Row)).Copy Лист2.[A4]
    Лист2.[A1] = Лист4.Range("A" & I)
    Лист2.[A2] = Лист4.Range("B" & I)
    With Лист2.Range("$A4:$N" & Лист2.Range("A" & Лист2.Rows.Count).End(xlUp).Row)
      .Borders.Weight = 2
      .WrapText = True
    End With
    Лист1.[A:N].AutoFilter
    
    If Лист2.Cells(1, 1).Value <> "" Then                           'заполняем сопроводиловку
        Лист3.Cells(11, 3).Value = n
        Лист3.Cells(12, 5).Value = Лист2.Cells(1, 1).Value
        Лист3.Cells(13, 5).Value = Лист2.Cells(2, 1).Value
        If ((Лист2.HPageBreaks.Count + 1) / 2) <> Fix((Лист2.HPageBreaks.Count + 1) / 2) Then
            Лист3.Cells(20, 3).Value = Fix((Лист2.HPageBreaks.Count + 1) / 2) + 1
        Else
            Лист3.Cells(20, 3).Value = (Fix((Лист2.HPageBreaks.Count + 1) / 2))
        End If
        Sheets("Формируемая сопроводиловка").Select
        ExecuteExcel4Macro "PRINT(1,,,1,,,,,,,,2,,,TRUE,,FALSE)"
        Sheets("Формируемый отчет").Select
        ExecuteExcel4Macro "PRINT(1,,,1,,,,,,,,2,,,TRUE,,FALSE)"
        n = n + 1
        With Лист5.Range("$A$" & Лист5.Rows.Count).End(xlUp).Offset(1).EntireRow
          .Cells(1, 1) = "Отчет в " + Лист2.Cells(1, 1).Value   'прописываем орган ФССП
          .Cells(1, 2) = "УФССП"                                'прописываем куда
          .Cells(1, 3) = "Гудовских Е.А."                       'прописываем кто подписал
          .Cells(1, 4) = Now()
          .Cells(1, 5) = .Cells(1, 1) & " от " & Format(.Cells(1, 4), "ddmmyyyy") & ".xlsx"
          Sheets("Формируемая сопроводиловка").Copy
          Application.DisplayAlerts = False
          ActiveWorkbook.SaveAs Filename:=.Cells(1, 5)
          ActiveWorkbook.Close
          Application.DisplayAlerts = True
          WB.Activate
        End With
    End If
    I = I + 1
  Wend
  Application.ScreenUpdating = True
End Sub

[AJIEXEY]

Сообщение от DiemonStar

в какой ячейке он будет содержаться? или вы планируете в исходном файле сделать список сохраненных сопроводиловок?

Назвали файлы правильно.

Все работает. Большое спасибо.
Только я, наверно, немного не правильно объяснил. Мне в файле, который создается именем ячейки+дата, должны быть два листа:
1)"Формируемый отчет"
2)"Формируемая сопроводиловка"
Попытался сам добавить не получилось. Добавьте, пожалуйста.

[AJIEXEY]

Помогите, пожалуйста.

[AJIEXEY]

Нашел еще одну тенденцию. Если я воспользовался этим макросом один раз, то во второй раз он не заработает в плане сохранения файлов именем ячейки.
мои действия:
1) заменил свой макрос Вашим
2) сохранил исходный файл
3) включаю макрос, первый раз файлы сохраняются
4) Потом выхожу из исходного файла без сохраняя, чтоб исходный файл не изменился
5) потом опять захожу. Не сохраняет

[DiemonStar]

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

измените так участок кода и Вы увидите диалог об этом.

          'Application.DisplayAlerts = False
          ActiveWorkbook.SaveAs Filename:=.Cells(1, 5)
          ActiveWorkbook.Close
          'Application.DisplayAlerts = True

так что либо оставляете так, либо перед повторным запуском удаляете ранее сформированные файлы.

Еще возможно решить проблему, добавив в имя файла метку времени:

.Cells(1, 5) = .Cells(1, 1) & " от " & Format(.Cells(1, 4), "DDMMYYYY  hhmm") & ".xlsx"

[AJIEXEY]

Я понял в чем дело. Когда я первый раз делаю, то он создает их в папке где находится исходник, а если использую повторно, то в папке "мои документы".

Еще раз спасибо.