Добрый вечер!
Пожалуйста, помогите написать программку в VBA.. и если можно, с комментариями кода.
Что нужно:
1. Со 2го Листа таблицы взять значение в ячейке "F3". (Сейчас это "C12707").
2. Найти "C12707" в таблице 1 в столбце "H" и скопировать всю строку с этим значением на "Лист 2" В строку 15 от столб. "A" до "P".
3. Имея на Листе 2 полученную строку(и) вытащить число из "А15" (при "C12707" это "168") и найти на "Листе 2" первое меньшее значение (т.е. первое число меньше 168) НО, при этом "B15" -1. (Там числа от 1-5. Если было 5 - берем 4, было 4 - берем 3 и так до 1. Если было 1- поиск закончен).
4. Нашли "167" при "4"... копируем эту строку в строку 16 от столб. "A" до "P".
5. Ищем следующее число на 1м листе меньше "167" в столбце "В" при уже "3" в столбце "С". И опять копируем строку на "Лист 2" уже в 17 строку..
6. Следующее значение уже "122" при "3". Ищем число меньше 122 на 2ке. и так до 1. (Пример будет в Excel).
7. В этом примере в Таблице при "C12707" Excel нашел 3 совпадения.
Это: 168 на уровне "5", 170 на уровне "5" и 329 на уровне "5" - значит нужно найти 15 строк. (Каждый уровень 5 разбираем до 1. Я разобрал только 168 для примера). Совпадений при каком-от "С129249" может быть много. Но чаще всего 1.
8. Перемножить все что в столбце "J" на "Листе 2" из каждого найденного "блока" строк. т.е. нашли "168" на уровне "5", разбили его до уровня "1" и перемножили все что в "J" и сложили это с другими такими "блоками". Для примера формула в "D11" на "Литсе2".
9. Желательно создать 2ю кнопку, при нажатии которой на "Листе 2" Остается все до 10 строки и только каждая 2я из найденныйх строк. Т.е. нашли "C12707" и в его строке "168" при уровне "5" спустились на уровень "4" и нашли первое число меньше 168 - это "167" и сохранили только эту строку.. после перемножения.. и так далее.
Вот есть часть кода на доработку.. ищет строки с совпадением из всех Excel в одной папке..:
Sub Ïîèñê_âî_âñåõ_ôàéëàõ()
Dim iShtName$, iPath$, iFileName$, firstAddress$
Dim iSheet As Worksheet, iFoundSht As Worksheet
Dim iTempWB As Workbook, iBazaWB As Workbook
Dim TextToFind As Variant, iFoundRng As Range
Dim FD As FileDialog, iLastRow&
Dim FoundAny As Boolean
Dim mrgArea As Range
Dim lRow&
TextToFind = Application.InputBox("Vvedite text dlia poiska:", "Poisk")
If TextToFind = "" Or TextToFind = False Then Exit Sub
TextToFind = Trim(TextToFind)
Set FD = Application.FileDialog(msoFileDialogFilePicker)
With FD
.AllowMultiSelect = False
.Title = "Ykagite liuboi fail v papke"
.ButtonName = "Vibrat6 papky"
If .Show = False Then Exit Sub Else iPath = Mid(.SelectedItems(1), 1, InStrRev(.SelectedItems(1), "\"))
End With
Set FD = Nothing
Workbooks.Add
Sheets.Add.Name = "Poisk"
Set iFoundSht = ActiveSheet
iFoundSht.Cells(1, 3) = "Ishem: " & TextToFind
iFoundSht.Cells(1, 3).Font.Bold = True
With Application
.ScreenUpdating = False
.Calculation = xlManual
.StatusBar = "Idet poisk..."
.ShowWindowsInTaskbar = False
iFileName = Dir(iPath & "*.xls")
Do While iFileName$ <> ""
If iFileName = ThisWorkbook.Name Then GoTo nextFile
Set iTempWB = Workbooks.Open(Filename:=iPath & iFileName, UpdateLinks:=False, ReadOnly:=True)
For Each iSheet In iTempWB.Sheets
If iSheet.FilterMode = True Then iSheet.ShowAllData
Set iFoundRng = iSheet.Cells.Find(What:=TextToFind, LookIn:=xlFormulas, LookAt:=xlPart)
If Not iFoundRng Is Nothing Then
FoundAny = True
firstAddress = iFoundRng.Address
Do
With iFoundSht
iLastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
If iLastRow = 1 Then iLastRow = 2
If iShtName <> iSheet.Name Then 'esli novii fail
With .Cells(iLastRow + 2, 3)
.Value = "Fail: " & iTempWB.Name & ", List: " & iSheet.Name
.Font.Bold = True
End With
End If
lRow = .Cells(.Rows.Count, 3).End(xlUp).Row + 1
If iSheet.Cells(iFoundRng.Row, "A").MergeCells Then
Set mrgArea = iSheet.Cells(iFoundRng.Row, "A").MergeArea
mrgArea.UnMerge
mrgArea.Cells(1).Copy Destination:=mrgArea.Resize(mrgArea.Rows.Count - 1, 1).Offset(1)
iSheet.Cells(iFoundRng.Row, "A").Resize(1, 100).Copy Destination:=.Cells(lRow, 3) 'kopirzem 100 ya4eek v stroke
mrgArea.Resize(mrgArea.Rows.Count - 1, 1).Offset(1).ClearContents
mrgArea.Merge
Else
iSheet.Cells(iFoundRng.Row, "A").Resize(1, 100).Copy Destination:=.Cells(lRow, 3) 'kopirzem 100 ya4eek v stroke
End If
.Cells(lRow, 1) = iSheet.Cells(iFoundRng.Row, "F") ' 4to nugno v ya4eeky A
.Cells(lRow, 2) = iTempWB.Name ' 4to nugno v ya4eeky B
iShtName = iSheet.Name
End With
Set iFoundRng = iSheet.Cells.FindNext(iFoundRng)
Loop While iFoundRng.Address <> firstAddress
Else
End If
Next
iTempWB.Close SaveChanges:=False
nextFile:
iFileName = Dir
Loop
.StatusBar = False
.ShowWindowsInTaskbar = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With
If FoundAny = False Then
MsgBox "text '" & TextToFind & "' ni w odnom iz failow " & Chr(10) & iPath & Chr(10) & " ne bil naiden!", 48, "ot4et"
iFoundSht.Parent.Close SaveChanges:=False
Exit Sub
End If
MsgBox "Poisk " & TextToFind & "zawershon", 64, "Poisk"
End Sub
Для оформления кода в сообщении служит кнопка с пиктограммой в виде решетки #.
ТЗ следует размещать в разделе платных заказов. Здесь помогают по конретным вопросам.