Профессиональные приемы работы в Microsoft Excel

Обмен опытом => Microsoft Excel => Тема начата: Dmitriy_10 от 18.08.2017, 22:50

Название: Поиск значений на Листе 1 копирование строк на лист 2 и дальнейшая работа с ними
Отправлено: Dmitriy_10 от 18.08.2017, 22:50
Добрый вечер!

Пожалуйста, помогите написать программку в 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
Название: Re: Поиск значений на Листе 1 копирование строк на лист 2 и дальнейшая работа с ними
Отправлено: vikttur от 19.08.2017, 01:23
Для оформления кода в сообщении служит кнопка с пиктограммой в виде решетки #.
ТЗ следует размещать в разделе платных заказов. Здесь помогают по конретным вопросам.