Копирование листа в другую(ие) книгу(и) по условию

Дата: Пятница, 30.10.2015, 12:39 | Сообщение № 1

Группа: Пользователи

Ранг: Участник

Сообщений: 54

Репутация: 0 ±

Замечаний: 0% ±

Excel 2007

Здравствуйте. Есть программа по заполнению и распечатыванию товарной накладной. Подскажите как сохранить готовую накладную в книгу имеющую название соответствующее имени того кому она выдана и на лист имеющий название даты выдачи и номера ТН, желательно чтобы программа сама создавала книгу если ТН человеку выдаётся впервые и добавляла лист если книга на человека уже заведена.
[moder]Приложите файл-пример[/moder]

Сообщение отредактировал Manyasha - Пятница, 30.10.2015, 12:43

Дата: Пятница, 30.10.2015, 13:12 | Сообщение № 2

Группа: Пользователи

Ранг: Участник

Сообщений: 54

Репутация: 0 ±

Замечаний: 0% ±

Excel 2007

Прикладываю файл. Смысл в том чтобы лист "накладная" копировался так же как вывелся на печать т.е. с учётом того, что некоторые ячейки скрыты фильтром. И ещё. Необходимо чтобы книга с именем получателя ТМЦ сохранялась в папку где лежит файл по оформлению ТМЦ.

К сообщению приложен файл: 5153420.xls (47.5 Kb)

Дата: Воскресенье, 01.11.2015, 15:06 | Сообщение № 3

Группа: Проверенные

Ранг: Ветеран

Сообщений: 980

Репутация: 127 ±

Замечаний: 0% ±

Excel 2007, Excel 2013

Sharf1, Код сохраняет в xlsx формате. И предусматривает, что файлики отдельные будут падать в ту же путевую папку, что и ваша изначальная книга, откуда вы этот лист сохраняете.
[vba]

Код

Sub SaveNakl()
Dim WB1 As Workbook
Dim WB2 As Workbook
Dim sht As Worksheet
Dim i As Long, i_n As Long
Dim path1 As String
Dim sht_index As Long
Set WB1 = ThisWorkbook
i_n = WB1.Worksheets("Накладная").Cells(Rows.Count, 2).End(xlUp).Row
path1 = WB1.Path
If Dir(path1 & "\" & WB1.Worksheets("Накладная").Range("U9") & ".xls") = "" Then
   Workbooks.Add
   Set WB2 = ActiveWorkbook
   WB1.Activate
   WB1.Worksheets("Накладная").Copy Before:=WB2.Worksheets(1)
   WB2.Worksheets(1).Name = Format(Now, "dd.mm.yyyy")
   WB2.SaveAs Filename:=path1 & "\" & WB1.Worksheets("Накладная").Range("U9") & ".xlsx"
Else
   Workbooks.Open (path1 & "\" & WB1.Worksheets("Накладная").Range("U9") & ".xlsx")
   Set WB2 = ActiveWorkbook
   For Each sht In WB2.Worksheets
      If sht.Name = Format(Now, "dd.mm.yyyy") Then
         sht_index = sht.Index
         Exit For
      End If
   Next sht
      If sht_index <> 0 Then
         WB1.Activate
         WB1.Worksheets("Накладная").Copy Before:=WB2.Worksheets(sht_index)
         WB2.Worksheets(sht_index + 1).Name = WB2.Worksheets(sht_index + 1).Name & "_"
         WB2.Worksheets(sht_index).Name = Format(Now, "dd.mm.yyyy")
         Application.DisplayAlerts = False
         WB2.Worksheets(sht_index + 1).Delete
         Application.DisplayAlerts = True
      Else
         WB1.Activate
         WB1.Worksheets("Накладная").Copy Before:=WB2.Worksheets(1)
         WB2.Worksheets(1).Name = Format(Now, "dd.mm.yyyy")
      End If
   WB2.Close True
End If
End Sub

[/vba]

Код

[/vba]Roman777

Много чего не знаю!!!!

СообщениеSharf1, Код сохраняет в xlsx формате. И предусматривает, что файлики отдельные будут падать в ту же путевую папку, что и ваша изначальная книга, откуда вы этот лист сохраняете.
[vba]

Код

[/vba]

Автор - Roman777
Дата добавления - 01.11.2015 в 15:06

Дата: Понедельник, 02.11.2015, 16:56 | Сообщение № 4

Группа: Пользователи

Ранг: Участник

Сообщений: 54

Репутация: 0 ±

Замечаний: 0% ±

Excel 2007

Уважаемый, Roman777. Ваш скрипт работает один раз, т.е. он создаёт книгу с копией накладной, но при этом когда вводится накладная на другую дату на существующее уже имя, то программа просит заменить существующий файл. И ещё вопрос. Возможно скопировать только лист "накладная" с вставленными формулами или можно получить копию не зависящую от формул исходника т.е. именно текст и числа которые подставляются формулами?

Дата: Понедельник, 02.11.2015, 18:00 | Сообщение № 5

Группа: Проверенные

Ранг: Ветеран

Сообщений: 980

Репутация: 127 ±

Замечаний: 0% ±

Excel 2007, Excel 2013

Sharf1, по поводу первого:

Извиняюсь, проверку на поиск книги не с тем расширением поставил.
А по поводу второго (сохранять только значения), щас прям быстро доправить не смогу, над отдельно диапазоны (объединённые) ячейки будет выделять и копировать-сохранять как значения, иного способа я не знаю...

Sharf1, по поводу первого:

Много чего не знаю!!!!

СообщениеSharf1, по поводу первого:

Автор - Roman777
Дата добавления - 02.11.2015 в 18:00

Manyasha

Дата: Понедельник, 02.11.2015, 18:08 | Сообщение № 6

Группа: Модераторы

Ранг: Старожил

Сообщений: 2198

Репутация: 902 ±

Замечаний: 0% ±

Excel 2010, 2016

Цитата Roman777, 02.11.2015 в 18:00, в сообщении № 5

сохранять только значения

вот так можно:[vba]

Код

With activesheet
.usedrange = .usedrange.value
End With

[/vba]

ЯД: 410013299366744 WM: R193491431804

Дата: Вторник, 03.11.2015, 10:07 | Сообщение № 7

Группа: Проверенные

Ранг: Ветеран

Сообщений: 980

Репутация: 127 ±

Замечаний: 0% ±

Excel 2007, Excel 2013

Manyasha, Добрый день! Спасибо за подсказку. Не знал о таком свойстве).
С помощью подсказки вышло как-то так:

[vba]

Код

Sub SaveNakl()
Dim WB1 As Workbook
Dim WB2 As Workbook
Dim sht As Worksheet
Dim i As Long, i_n As Long, k As Long
Dim path1 As String
Dim sht_index As Long
Dim hidrows() As Long
Set WB1 = ThisWorkbook
i_n = WB1.Worksheets("Накладная").Cells(Rows.Count, 2).End(xlUp).Row
ReDim hidrows(i_n - 1)
For i = 1 To i_n
If WB1.Worksheets("Накладная").Rows(i).Hidden = True Then
   hidrows(i - 1) = 1
End If
Next i
path1 = WB1.Path
If Dir(path1 & "\" & WB1.Worksheets("Накладная").Range("U9") & ".xlsx") = "" Then
Workbooks.Add
Set WB2 = ActiveWorkbook
WB1.Activate
WB1.Worksheets("Накладная").Copy Before:=WB2.Worksheets(1)
WB2.Worksheets(1).Name = Format(Now, "dd.mm.yyyy")
'________раскрываем скрытые строки (для применения свойства usedrange)
For i = 1 To i_n
If hidrows(i - 1) = 1 Then
   WB2.Worksheets(1).Rows(i).Hidden = False
End If
Next i
'________сохраняем значения
With WB2.Worksheets(1)
.UsedRange = .UsedRange.Value
End With
'________скрываем ранее скрытые строки (для применения свойства usedrange)
For i = 1 To i_n
If hidrows(i - 1) = 1 Then
   WB2.Worksheets(1).Rows(i).Hidden = True
End If
Next i
WB2.SaveAs Filename:=path1 & "\" & WB1.Worksheets("Накладная").Range("U9") & ".xlsx"
Else
Workbooks.Open (path1 & "\" & WB1.Worksheets("Накладная").Range("U9") & ".xlsx")
Set WB2 = ActiveWorkbook
For Each sht In WB2.Worksheets
    If sht.Name = Format(Now, "dd.mm.yyyy") Then
        sht_index = sht.Index
        Exit For
    End If
Next sht
    If sht_index <> 0 Then
        WB1.Activate
        WB1.Worksheets("Накладная").Copy Before:=WB2.Worksheets(sht_index)
        WB2.Worksheets(sht_index + 1).Name = WB2.Worksheets(sht_index + 1).Name & "_"
        WB2.Worksheets(sht_index).Name = Format(Now, "dd.mm.yyyy")
        For i = 1 To i_n
          If hidrows(i - 1) = 1 Then
             WB2.Worksheets(sht_index).Rows(i).Hidden = False
          End If
        Next i
        With WB2.Worksheets(sht_index)
          .UsedRange = .UsedRange.Value
        End With
        For i = 1 To i_n
          If hidrows(i - 1) = 1 Then
             WB2.Worksheets(sht_index).Rows(i).Hidden = True
          End If
        Next i
        Application.DisplayAlerts = False
        WB2.Worksheets(sht_index + 1).Delete
        Application.DisplayAlerts = True
    Else
        WB1.Activate
        WB1.Worksheets("Накладная").Copy Before:=WB2.Worksheets(1)
        WB2.Worksheets(1).Name = Format(Now, "dd.mm.yyyy")
        For i = 1 To i_n
          If hidrows(i - 1) = 1 Then
             WB2.Worksheets(1).Rows(i).Hidden = False
          End If
        Next i
        With WB2.Worksheets(1)
          .UsedRange = .UsedRange.Value
        End With
        For i = 1 To i_n
          If hidrows(i - 1) = 1 Then
             WB2.Worksheets(1).Rows(i).Hidden = True
          End If
        Next i
    End If
WB2.Close True
End If
End Sub

[/vba]

Вышло громоздко, знаю, что можно упростить, но тут вроде не грех и так оставить...)

Manyasha, Добрый день! Спасибо за подсказку. Не знал о таком свойстве).
С помощью подсказки вышло как-то так:

[vba]

Код

[/vba]

Вышло громоздко, знаю, что можно упростить, но тут вроде не грех и так оставить...)Roman777

Много чего не знаю!!!!

СообщениеManyasha, Добрый день! Спасибо за подсказку. Не знал о таком свойстве).
С помощью подсказки вышло как-то так:

[vba]

Код

[/vba]

Вышло громоздко, знаю, что можно упростить, но тут вроде не грех и так оставить...)

Автор - Roman777
Дата добавления - 03.11.2015 в 10:07

Дата: Вторник, 03.11.2015, 13:03 | Сообщение № 8

Группа: Пользователи

Ранг: Участник

Сообщений: 54

Репутация: 0 ±

Замечаний: 0% ±

Excel 2007

Roman777, Спасибо Вам большое. Но возникает проблема следующего характера. Если человек получил накланую один раз в день, то всё замечательно, а вот если более одного раза, то оформленная до этого накладная замещается последней с потерей данных. Возможно ли сделать сохранение без потери предыдущей накладной?

Дата: Вторник, 03.11.2015, 15:38 | Сообщение № 9

Группа: Проверенные

Ранг: Ветеран

Сообщений: 980

Репутация: 127 ±

Замечаний: 0% ±

Excel 2007, Excel 2013

Sharf1, просто вместо удаления листа, при нахождении, нужно добавлять к его наименованию символы, чтобы имя не дублировалось. В приложенном макросе, имена листов будут, начиная с повторной в этот день накладной заканчиваться на "_1", "_2"... и тд.

[vba]

Код

Sub SaveNakl()
Dim WB1 As Workbook
Dim WB2 As Workbook
Dim sht As Worksheet
Dim i As Long, i_n As Long, k As Long
Dim path1 As String
Dim sht_index As Long
Dim hidrows() As Long
Set WB1 = ThisWorkbook
i_n = WB1.Worksheets("Накладная").Cells(Rows.Count, 2).End(xlUp).Row
ReDim hidrows(i_n - 1)
For i = 1 To i_n
If WB1.Worksheets("Накладная").Rows(i).Hidden = True Then
   hidrows(i - 1) = 1
End If
Next i
path1 = WB1.Path
If Dir(path1 & "\" & WB1.Worksheets("Накладная").Range("U9") & ".xlsx") = "" Then
Workbooks.Add
Set WB2 = ActiveWorkbook
WB1.Activate
WB1.Worksheets("Накладная").Copy Before:=WB2.Worksheets(1)
WB2.Worksheets(1).Name = Format(Now, "dd.mm.yyyy")
'________раскрываем скрытые строки (для применения свойства usedrange)
For i = 1 To i_n
If hidrows(i - 1) = 1 Then
   WB2.Worksheets(1).Rows(i).Hidden = False
End If
Next i
'________сохраняем значения
With WB2.Worksheets(1)
.UsedRange = .UsedRange.Value
End With
'________скрываем ранее скрытые строки (для применения свойства usedrange)
For i = 1 To i_n
If hidrows(i - 1) = 1 Then
   WB2.Worksheets(1).Rows(i).Hidden = True
End If
Next i
WB2.SaveAs Filename:=path1 & "\" & WB1.Worksheets("Накладная").Range("U9") & ".xlsx"
Else
Workbooks.Open (path1 & "\" & WB1.Worksheets("Накладная").Range("U9") & ".xlsx")
Set WB2 = ActiveWorkbook
For Each sht In WB2.Worksheets
    If InStr(1, sht.Name, Format(Now, "dd.mm.yyyy"), vbTextCompare) > 0 Then
        If sht_index = 0 Then
           sht_index = sht.Index
        End If
        k = k + 1
    End If
Next sht
    If sht_index <> 0 Then
        WB1.Activate
        WB1.Worksheets("Накладная").Copy Before:=WB2.Worksheets(sht_index)
        WB2.Worksheets(sht_index).Name = Format(Now, "dd.mm.yyyy") & "_" & k
        For i = 1 To i_n
          If hidrows(i - 1) = 1 Then
             WB2.Worksheets(sht_index).Rows(i).Hidden = False
          End If
        Next i
        With WB2.Worksheets(sht_index)
          .UsedRange = .UsedRange.Value
        End With
        For i = 1 To i_n
          If hidrows(i - 1) = 1 Then
             WB2.Worksheets(sht_index).Rows(i).Hidden = True
          End If
        Next i
    Else
        WB1.Activate
        WB1.Worksheets("Накладная").Copy Before:=WB2.Worksheets(1)
        WB2.Worksheets(1).Name = Format(Now, "dd.mm.yyyy")
        For i = 1 To i_n
          If hidrows(i - 1) = 1 Then
             WB2.Worksheets(1).Rows(i).Hidden = False
          End If
        Next i
        With WB2.Worksheets(1)
          .UsedRange = .UsedRange.Value
        End With
        For i = 1 To i_n
          If hidrows(i - 1) = 1 Then
             WB2.Worksheets(1).Rows(i).Hidden = True
          End If
        Next i
    End If
WB2.Close True
End If
End Sub

[/vba]

[vba]

Код

Sub SaveNakl()
Dim WB1 As Workbook
Dim WB2 As Workbook
Dim sht As Worksheet
Dim i As Long, i_n As Long, k As Long
Dim path1 As String
Dim sht_index As Long
Dim hidrows() As Long
Set WB1 = ThisWorkbook
i_n = WB1.Worksheets("Накладная").Cells(Rows.Count, 2).End(xlUp).Row
ReDim hidrows(i_n - 1)
For i = 1 To i_n
If WB1.Worksheets("Накладная").Rows(i).Hidden = True Then
   hidrows(i - 1) = 1
End If
Next i
path1 = WB1.Path
If Dir(path1 & "\" & WB1.Worksheets("Накладная").Range("U9") & ".xlsx") = "" Then
Workbooks.Add
Set WB2 = ActiveWorkbook
WB1.Activate
WB1.Worksheets("Накладная").Copy Before:=WB2.Worksheets(1)
WB2.Worksheets(1).Name = Format(Now, "dd.mm.yyyy")
'________раскрываем скрытые строки (для применения свойства usedrange)
For i = 1 To i_n
If hidrows(i - 1) = 1 Then
   WB2.Worksheets(1).Rows(i).Hidden = False
End If
Next i
'________сохраняем значения
With WB2.Worksheets(1)
.UsedRange = .UsedRange.Value
End With
'________скрываем ранее скрытые строки (для применения свойства usedrange)
For i = 1 To i_n
If hidrows(i - 1) = 1 Then
   WB2.Worksheets(1).Rows(i).Hidden = True
End If
Next i
WB2.SaveAs Filename:=path1 & "\" & WB1.Worksheets("Накладная").Range("U9") & ".xlsx"
Else
Workbooks.Open (path1 & "\" & WB1.Worksheets("Накладная").Range("U9") & ".xlsx")
Set WB2 = ActiveWorkbook
For Each sht In WB2.Worksheets
    If InStr(1, sht.Name, Format(Now, "dd.mm.yyyy"), vbTextCompare) > 0 Then
        If sht_index = 0 Then
           sht_index = sht.Index
        End If
        k = k + 1
    End If
Next sht
    If sht_index <> 0 Then
        WB1.Activate
        WB1.Worksheets("Накладная").Copy Before:=WB2.Worksheets(sht_index)
        WB2.Worksheets(sht_index).Name = Format(Now, "dd.mm.yyyy") & "_" & k
        For i = 1 To i_n
          If hidrows(i - 1) = 1 Then
             WB2.Worksheets(sht_index).Rows(i).Hidden = False
          End If
        Next i
        With WB2.Worksheets(sht_index)
          .UsedRange = .UsedRange.Value
        End With
        For i = 1 To i_n
          If hidrows(i - 1) = 1 Then
             WB2.Worksheets(sht_index).Rows(i).Hidden = True
          End If
        Next i
    Else
        WB1.Activate
        WB1.Worksheets("Накладная").Copy Before:=WB2.Worksheets(1)
        WB2.Worksheets(1).Name = Format(Now, "dd.mm.yyyy")
        For i = 1 To i_n
          If hidrows(i - 1) = 1 Then
             WB2.Worksheets(1).Rows(i).Hidden = False
          End If
        Next i
        With WB2.Worksheets(1)
          .UsedRange = .UsedRange.Value
        End With
        For i = 1 To i_n
          If hidrows(i - 1) = 1 Then
             WB2.Worksheets(1).Rows(i).Hidden = True
          End If
        Next i
    End If
WB2.Close True
End If
End Sub

[/vba]

Много чего не знаю!!!!

СообщениеSharf1, просто вместо удаления листа, при нахождении, нужно добавлять к его наименованию символы, чтобы имя не дублировалось. В приложенном макросе, имена листов будут, начиная с повторной в этот день накладной заканчиваться на "_1", "_2"... и тд.

[vba]

Код

Sub SaveNakl()
Dim WB1 As Workbook
Dim WB2 As Workbook
Dim sht As Worksheet
Dim i As Long, i_n As Long, k As Long
Dim path1 As String
Dim sht_index As Long
Dim hidrows() As Long
Set WB1 = ThisWorkbook
i_n = WB1.Worksheets("Накладная").Cells(Rows.Count, 2).End(xlUp).Row
ReDim hidrows(i_n - 1)
For i = 1 To i_n
If WB1.Worksheets("Накладная").Rows(i).Hidden = True Then
   hidrows(i - 1) = 1
End If
Next i
path1 = WB1.Path
If Dir(path1 & "\" & WB1.Worksheets("Накладная").Range("U9") & ".xlsx") = "" Then
Workbooks.Add
Set WB2 = ActiveWorkbook
WB1.Activate
WB1.Worksheets("Накладная").Copy Before:=WB2.Worksheets(1)
WB2.Worksheets(1).Name = Format(Now, "dd.mm.yyyy")
'________раскрываем скрытые строки (для применения свойства usedrange)
For i = 1 To i_n
If hidrows(i - 1) = 1 Then
   WB2.Worksheets(1).Rows(i).Hidden = False
End If
Next i
'________сохраняем значения
With WB2.Worksheets(1)
.UsedRange = .UsedRange.Value
End With
'________скрываем ранее скрытые строки (для применения свойства usedrange)
For i = 1 To i_n
If hidrows(i - 1) = 1 Then
   WB2.Worksheets(1).Rows(i).Hidden = True
End If
Next i
WB2.SaveAs Filename:=path1 & "\" & WB1.Worksheets("Накладная").Range("U9") & ".xlsx"
Else
Workbooks.Open (path1 & "\" & WB1.Worksheets("Накладная").Range("U9") & ".xlsx")
Set WB2 = ActiveWorkbook
For Each sht In WB2.Worksheets
    If InStr(1, sht.Name, Format(Now, "dd.mm.yyyy"), vbTextCompare) > 0 Then
        If sht_index = 0 Then
           sht_index = sht.Index
        End If
        k = k + 1
    End If
Next sht
    If sht_index <> 0 Then
        WB1.Activate
        WB1.Worksheets("Накладная").Copy Before:=WB2.Worksheets(sht_index)
        WB2.Worksheets(sht_index).Name = Format(Now, "dd.mm.yyyy") & "_" & k
        For i = 1 To i_n
          If hidrows(i - 1) = 1 Then
             WB2.Worksheets(sht_index).Rows(i).Hidden = False
          End If
        Next i
        With WB2.Worksheets(sht_index)
          .UsedRange = .UsedRange.Value
        End With
        For i = 1 To i_n
          If hidrows(i - 1) = 1 Then
             WB2.Worksheets(sht_index).Rows(i).Hidden = True
          End If
        Next i
    Else
        WB1.Activate
        WB1.Worksheets("Накладная").Copy Before:=WB2.Worksheets(1)
        WB2.Worksheets(1).Name = Format(Now, "dd.mm.yyyy")
        For i = 1 To i_n
          If hidrows(i - 1) = 1 Then
             WB2.Worksheets(1).Rows(i).Hidden = False
          End If
        Next i
        With WB2.Worksheets(1)
          .UsedRange = .UsedRange.Value
        End With
        For i = 1 To i_n
          If hidrows(i - 1) = 1 Then
             WB2.Worksheets(1).Rows(i).Hidden = True
          End If
        Next i
    End If
WB2.Close True
End If
End Sub

[/vba]

Автор - Roman777
Дата добавления - 03.11.2015 в 15:38

Дата: Вторник, 03.11.2015, 16:11 | Сообщение № 10

Группа: Пользователи

Ранг: Участник

Сообщений: 54

Репутация: 0 ±

Замечаний: 0% ±

Excel 2007

Roman777, огромное Вам спасибо. Так же спасибо Manyasha за участие. Жалко не даёт больше одного раза повысить репутацию. Не поленился бы, раз 50 повысил)))))