Цикл в столбце и запись в файл

[Любовь87]

Подскажите, пожалуйста, как избавиться от создания двух книг(с шапкой и без шапки)? Необходимо создание книги в конкретной папке и с конкретной шапкой, которая должна переносится вместе со строчками 102 кода. Как это исправить?

Sub Perenos()


Dim x As Range, rr As Range: Application.ScreenUpdating = False
Set x = [E:E].Find(102, , , xlWhole)
If Not x Is Nothing Then
[E:E].ColumnDifferences(x).EntireRow.Hid den = True
Set rr = ActiveSheet.UsedRange.SpecialCells( xlCellTypeVisible).EntireRow
Rows.Hidden = False
rr.Copy Workbooks.Add.Sheets(1).[a1]

Dim sh As Worksheet
Set sh = Workbooks.Add.Sheets(1)
sh.[a1] = "Ïåðâàÿ ÿ÷åéêà øàïêè"
rr.Copy sh.[a2]

rr.Delete
End If

End Sub

[Любовь87]

Подскажите пожалуйста, как исправить:
Мне нужно чтобы перенос сточек со 102 кодом переносился в новую книгу со 2-ой строки, а на первую вставала шапка.

Dim x As Range, rr As Range: Application.ScreenUpdating = False
Set x = [E:E].Find(102, , , xlWhole)
If Not x Is Nothing Then
[E:E].ColumnDifferences(x).EntireRow.Hid den = True
Set rr = ActiveSheet.UsedRange.SpecialCells( xlCellTypeVisible).EntireRow
Rows.Hidden = False

Dim sh As Worksheet
Set sh = Workbooks.Add.Sheets(1)
sh.[a1] = "Сотрудник"
sh.[b1] = "Год"
sh.[c1] = "месяц регистрации"
sh.[d1] = "месяц действия"
sh.[e1] = "вид расчёта"
sh.[f1] = "сумма"

rr.Copy Workbooks.Add.Sheets(1).[a2]

rr.Delete
End If

У меня создаётся одна книга - без шапки. и вторая книга - одна шапка. Подскажите пожалуйста как объединить?

[Hugo121]

Извините, совсем забыл про тему... Но Вы и сами почти сделали, осталась мелочь
rr.Copy sh.[a2]

Dim x As Range, rr As Range: Application.ScreenUpdating = False
Set x = [E:E].Find(102, , , xlWhole)
If Not x Is Nothing Then
[E:E].ColumnDifferences(x).EntireRow.Hidden = True
Set rr = ActiveSheet.UsedRange.SpecialCells(xlCellTypeVisible).EntireRow
Rows.Hidden = False

Dim sh As Worksheet
Set sh = Workbooks.Add.Sheets(1)
sh.[a1] = "Сотрудник"
sh.[b1] = "Год"
sh.[c1] = "месяц регистрации"
sh.[d1] = "месяц действия"
sh.[e1] = "вид расчёта"
sh.[f1] = "сумма"

rr.Copy sh.[a2]

rr.Delete
End If

[Любовь87]

Спасибо. А подскажите как мне задать, чтобы эта книга сохранялась сама в указанной папке и с названием:
Sub Perenos()

Dim WBk As Workbook
Dim Путь к папке As String
Dim WSheet As Worksheet
Dim Путь к файлу As String
Dim WBN As Workbook
Dim WSh As Worksheet


Dim x As Range, rr As Range: Application.ScreenUpdating = False
Set x = [E:E].Find(102, , , xlWhole)
If Not x Is Nothing Then
[E:E].ColumnDifferences(x).EntireRow.Hid den = True
Set rr = ActiveSheet.UsedRange.SpecialCells( xlCellTypeVisible).EntireRow
Rows.Hidden = False

Dim sh As Worksheet
Set sh = Workbooks.Add.Sheets(1)
sh.[a1] = "Сотрудник"
sh.[b1] = "Год"
sh.[c1] = "месяц регистрации"
sh.[d1] = "месяц действия"
sh.[e1] = "вид расчёта"
sh.[f1] = "сумма"

rr.Copy sh.[a2]

rr.Delete
End If

Set WBk = ThisWorkbook

Путь к папке = WBk.Path & "\DBF1\"
On Error Resume Next: MkDir Путь к папке
Путь к файлу = Путь к папке & "Сдельная" & WSheet.Range("J1") & WSheet.Range("K1") & ".xls"

Set WBN = Workbooks.Add(xlWBATWorksheet)
Set WSh = WBN.Worksheets(1)
WSh.Name = "Swod1"

WBN.SaveAs FileName:=Путь к файлу, FileFormat:=xlNormal, CreateBackup:=False
WBN.Close SaveChanges:=True

End Sub

Папка DBF1 уже создана, и в неё записывается файл с остальными кодами. А этот лист несохраняется(((

[Hugo121]

Попробуйте

sh.parent.SaveAs FileName:=

и далее нужный путь (я уже запутался... )
Ну и закрыть в конце

sh.parent Close 0

Поясню - sh это у Вас лист новой книги.
А sh.parent - это будет сама эта книга (т.к. она явно нигде не прописана в ссылке).
Можно было сделать иначе (я обычно так делаю) - задаём ссылку на новую книгу, потом ссылку на нужный лист этой книги.
Далее работаем уже без Parent, т.к. есть прямые ссылки на оба объекта.

[Любовь87]

ПутьКПапке = WBk.Path & "\DBF1\"
On Error Resume Next: MkDir ПутьКПапке
ПутьКФайлу = ПутьКПапке & "Сдельная" & WSheet.Range("J1") & WSheet.Range("K1") & ".xls"

sh.Parent.SaveAs FileName:=ПутьКФайлу, FileFormat:=xlNormal, CreateBackup:=False
sh.Parent.Close 0

Похоже не видит папку DBF1. Ругается на первую строчку. Что нужно ещё указать?

[Hugo121]

Трудно сказать без примера в файле.
У меня есть такой пример кода (у Вас в общем аналогично):

Private Sub Workbook_BeforeClose(Cancel As Boolean)
    Dim p$, n$
    p = ThisWorkbook.Path & "\Архив\"
    n = Split(ThisWorkbook.Name, ".")(0) & "_" & Month(Date) & "_" & Year(Date)
    On Error Resume Next
    Application.DisplayAlerts = 0
    If Not PathExists(p) Then MkDir p
    ThisWorkbook.SaveCopyAs (p & n & ".xlsm")
    Application.DisplayAlerts = -1
End Sub


И в общий модуль:
Function PathExists(pname) As Boolean
' Возвращает ИСТИНА, если путь существует
Dim x As String
On Error Resume Next
x = GetAttr(pname) And 0
PathExists = (Err = 0)
End Function

[Любовь87]

Посмотрите пожалуйста , как в моём случае сделано. что не правильно?

[Hugo121]

Забыли в Sub Perenos() одну строку в начале добавить:
Set WBk = ThisWorkbook
Хотя можно задать эту переменную публичной, и тогда хватает её задать в первом коде.
А так вроде всё работает.
Если проходить пошагово, то видно, что ПутьКПапке = WBk.Path & "\DBF1\" не формирется вообще, т.к. срабатывает On Error Resume Next из верхнего кода (это нужно отключать, когда более не требуется).

[Любовь87]

Файл в папке DBF1 только один создаётся - Сетевая, а файл - Сдельная не создаётся. и никаких предупреждений не пишет. Почему?