Формирование реестра из данных первых листов книг

[z21231904]

Здравствуйте.
Подскажите пожалуйста. Есть папка, в ней создаются файлы, где на первом листе счет-фактура (файлы 1,2) и файл с реестром (реестр). В счет-фактуре для реестра нужны определенные данные ячеек.
Как написать макрос, чтобы после создания нового файла с счет-фактурой (счет-фактура создается путем копирования предыдущей) при первом сохранении данные автоматически переносились в реестр, реестр после переноса открывается.

[z21231904]

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

[The_Prist]

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

как программно найти ячейку с текстом "ааа" и перейти на ячейку в трех столбцах от неё в этой же строке?

Sheets("Лист1").Usedrange.Find("aaa ",,xlvalues,xlWhole).offset(,3).Sel ect

[z21231904]

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

Sheets("Лист1").Usedrange.Find("aaa ",,xlvalues,xlWhole).offset(,3).Sel ect

Ясно, спасибо.

[z21231904]

Добрался до кода
If Sheet.Name Like sSheetName Then
Sheet.Activate
Select Case iBeginRange.Count
Case 1
lLastrow = Cells(1, 1).SpecialCells(xlLastCell).Row
iLastColumn = Cells.SpecialCells(xlLastCell).Colu mn
iCopyAddress = Range(Cells(iBeginRange.Row, iBeginRange.Column), Cells(lLastrow, iLastColumn)).Address
Case Else
iCopyAddress = iBeginRange.Address
lLastrow = iBeginRange.Rows.Count
iLastColumn = iBeginRange.Columns.Count
End Select
lLastRowMyBook = ThisWorkbook.Sheets(DataSheet).Cell s.SpecialCells(xlLastCell).Row + 1
iRngAddress = Range(Cells(lLastRowMyBook, 1), Cells(lLastRowMyBook + lLastrow, iLastColumn)).Address
Sheet.Range(iCopyAddress).Copy Destination:=ThisWorkbook.Sheets(Da taSheet).Range(iRngAddress)
End If

а он для диапазонов, а как его переделать для ячеек? Помогите.

[z21231904]

И так и эдак, не получается

Вот код, где нужно выборку диапазонов заменить на выборку ячейки

Sub Consolidated_Range_of_Books_and_She ets()
Dim iPivotRange As Range, iDestinationRange As Range, iBeginRange As Range, Sheet
Dim iRngAddress As String, oAwb As String, DataSheet As String, _
iCopyAddress As String, sSheetName As String, oFile
Dim lLastrow As Long, lLastRowMyBook As Long
Dim iLastColumn As Integer
Dim Str() As String

ThisWorkbook.Sheets.Add After:=Sheets(Sheets.Count)
DataSheet = ThisWorkbook.ActiveSheet.Name
On Error Resume Next
Set iBeginRange = Application.InputBox("Выберите диапазон сбора данных." & vbCrLf & _
"1. При выборе только одной ячейки данные будут собраны со всех листов начиная с этой ячейки. " & _
vbCrLf & "2. При выделении нескольких ячеек данные будут собраны только с указанного диапазона всех листов.", Type:=8)
If iBeginRange Is Nothing Then Exit Sub
sSheetName = InputBox("Введите имя листа, с которого собирать данные(если не указан, то данные собираются со всех листов)", "Параметр")
If sSheetName = "" Then sSheetName = "*"
On Error GoTo 0
With Application.FileDialog(msoFileDialo gFilePicker)
.AllowMultiSelect = True
.InitialFileName = "*.*"
.Title = "Выберите файлы"
If .Show = False Then Exit Sub
For Each oFile In .SelectedItems
Workbooks.OpenText Filename:=oFile
oAwb = Dir(oFile, vbDirectory)

Application.ScreenUpdating = False
Workbooks(oAwb).Activate
For Each Sheet In Sheets
If Sheet.Name Like sSheetName Then
Sheet.Activate
Select Case iBeginRange.Count
Case 1
lLastrow = Cells(1, 1).SpecialCells(xlLastCell).Row
iLastColumn = Cells.SpecialCells(xlLastCell).Colu mn
iCopyAddress = Range(Cells(iBeginRange.Row, iBeginRange.Column), Cells(lLastrow, iLastColumn)).Address
Case Else
iCopyAddress = iBeginRange.Address
lLastrow = iBeginRange.Rows.Count
iLastColumn = iBeginRange.Columns.Count
End Select
lLastRowMyBook = ThisWorkbook.Sheets(DataSheet).Cell s.SpecialCells(xlLastCell).Row + 1
iRngAddress = Range(Cells(lLastRowMyBook, 1), Cells(lLastRowMyBook + lLastrow, iLastColumn)).Address
Sheet.Range(iCopyAddress).Copy Destination:=ThisWorkbook.Sheets(Da taSheet).Range(iRngAddress)
End If
Next Sheet
Workbooks(oAwb).Close False
Next oFile
End With
Application.ScreenUpdating = True
End Sub

Вопрос как?

[The_Prist]

Понимаете в чем проблема - непонятно, что именно Вам надо скопировать и перенести в Реестр. Я вот файлы примеров посмотрел - а там нет предполагаемого результата...

[z21231904]

Виноват. добавил желаемый результат.

[The_Prist]

Вот. Смотрите.

[z21231904]

Да, то что нужно. Хотел отблагодарить "в самый раз", но там от вас счет нужен.

И, простите за наглость, можно как нибудь из "Счет-фактура № 2 от 10 мая 2000г." выделить дату в фомате "дата" и поместить в столбец дата?