Сканирование Excel

[Hausedark3]

Здраствуйте, помогите пожалуйста решить задачу, в файле будет думаю все понятнее но так в крации на словах, в этом документе 2 листа один с информацией другой якобы с таблицей, на первом лесте сама таблица с кнопкой, при нажатии на которою должно произойти якобы сканирование "листа2" с последующем заполнением таблици на "листе1", кнопка кабы должна понять какое значение стоит в какой либо строке и подставить определенную ячейку в таблицу, значение в виде цифр от 1 до 9, но и тут же есть один момент, строчка которая должна в нескольких ячейках таблици записатся в ней значение "123456" в общем нужно чтобы кнока понимала как будто в этой ячейке 6 разных чисел и соответственно записала некую ячейку в ячейки таблици "листа1"

Тут сама таблица и полная информация от куда должно идти заполнение, на втором листе пометил важные столбики.
Если не трудно помогите еще со столбиком "Кол-во часов" первого листа, оно должно заполнятся по столбику "ГОС" второго листа, "ГОС" должен делится на количество знаков столбиков "Желтого" цвета.
Ну к примеру Физическая культура ее семестры 123456 и ГОС ее 408, следовательно 408 нужно делить на 6, и записать результат в первой таблицы в первых 6-ти семестрах где стоит Физическая культура.

[Hugo121]

Код с планеты добить не пытаетесь?
Эти Ваши объединённые ячейки...
Это тоже ещё только заготовка - для первой пары таблиц. И там есть шероховатось - нужно вероятно вводить доп. условия, или анализировать не массив, а данные непосредственно с листа в связке с форматом ячеек.

Private Sub CommandButton1_Click()
    Dim a(), i As Byte, ii As Byte, iii As Byte, x As Byte
    a = Sheets("Лист2").Range("A9").CurrentRegion.Value

    For i = 3 To 53 Step 10
        ReDim b(1 To 9, 1 To 1)
        ReDim bb(1 To 9, 1 To 1)
        iii = 0
        x = x + 1
        For ii = 3 To UBound(a)
            If InStr(a(ii, 3) & a(ii, 4), x) Then
                iii = iii + 1
                b(iii, 1) = a(ii, 2)
                bb(iii, 1) = a(ii, 10) / Len(a(ii, 3) & a(ii, 4))
            End If
        Next
        Cells(i, 3).Resize(9, 1) = b
        Cells(i, 13).Resize(9, 1) = bb
    Next
End Sub

P.S. Вообще-то по факту здесь всюду вместо 9 нужно писать 6 - т.к. цикл For i = 3 To 53 Step 10 имеет всего 6 шагов... в отличие от того первого примера.

[Hausedark3]

К сожалению в VBA не селен, этот код работает хорошо, но ему как то ограничить видимость поиска нужно бы) чтобы он видел только дисциплины, а там что вы говорили изменить 9 на 6 это я так понял максимальное число какое в ячейке? это как бы идет номер семестра и дальше там должны быть 7 и 8) только как сделать чтобы он смог просматривать все те таблицы листа2 и то, ту часть где дисциплины, и вводил после также в 2 таблицы по номеру семестра.

Ну суть вы поняли)

[Hugo121]

Не вполне понял, но что-то сделал
Про 9 я ошибся - это число должно быть равно числу заполняемых строк семестра, т.е. количеству предметов, т.е. 10.
Лишние "жирные" строки откинул анализом столбца с КП - беру только те, где там пусто.
Таблицы второго листа берутся все (первые две строки листа откидываю, но можно и не откидывать - они проигнорируются по той же причине, что и "жирные" строки)
Но 85-я строка явно лишняя...

Private Sub CommandButton1_Click()
    Dim a(), i As Byte, ii As Byte, iii As Byte, x As Byte
    a = Sheets("Лист2").UsedRange.Value

    For i = 3 To 53 Step 10
        ReDim b(1 To 10, 1 To 1)
        ReDim bb(1 To 10, 1 To 1)
        iii = 0
        x = x + 1
        For ii = 1 To UBound(a)
            If Len(a(ii, 5)) = 0 Then
                If InStr(a(ii, 3) & a(ii, 4), x) Then
                    iii = iii + 1
                    b(iii, 1) = a(ii, 2)
                    bb(iii, 1) = a(ii, 10) / Len(a(ii, 3) & a(ii, 4))
                End If
            End If
        Next
        Cells(i, 3).Resize(10, 1) = b
        Cells(i, 13).Resize(10, 1) = bb
    Next

    For i = 66 To 97 Step 10
        ReDim b(1 To 10, 1 To 1)
        ReDim bb(1 To 10, 1 To 1)
        iii = 0
        x = x + 1
        For ii = 1 To UBound(a)
            If Len(a(ii, 5)) = 0 Then
                If InStr(a(ii, 3) & a(ii, 4), x) Then
                    iii = iii + 1
                    b(iii, 1) = a(ii, 2)
                    bb(iii, 1) = a(ii, 10) / Len(a(ii, 3) & a(ii, 4))
                End If
            End If
        Next
        Cells(i, 3).Resize(10, 1) = b
        Cells(i, 13).Resize(10, 1) = bb
    Next

End Sub