Добрый день! Появилась проблема-есть очень большой обьем данных в виде матрицы с именами,оценками и названием предмета .Нужно чтобы эксель определял пустые ячейки(без оценки) и на основе их формировал список с именами и названием предмета по которому оценка не стоит.
Добрый день! Появилась проблема-есть очень большой обьем данных в виде матрицы с именами,оценками и названием предмета .Нужно чтобы эксель определял пустые ячейки(без оценки) и на основе их формировал список с именами и названием предмета по которому оценка не стоит.lianei2456
Sub u_963() Application.ScreenUpdating = False a = Cells(Rows.Count, "a").End(xlUp).Row d = Cells(1, Columns.Count).End(xlToLeft).Column If a > 1 Then b = Application.Match("ÔÈÎ ñòóäåíòà", Range("a2:a" & a), 0) If IsNumeric(b) Then If a > b + 1 Then Range("a" & b + 2 & ":b" & a).Clear For c = 2 To b e = Range("a" & c).Value If e <> "" Then f = Application.Count(Range(Cells(c, 3), Cells(c, d))) If f < d - 2 Then For g = 1 To d - 2 - f s = Cells(c, "c").Address t = Cells(c, d).Address u = s & ":" & t i = Evaluate("=SMALL(IF(" & u & "="""",COLUMN(" & u & "))," & g & ")") j = Cells(1, i).Value k = Cells(Rows.Count, "a").End(xlUp).Row + 1 Range("a" & k) = e Range("b" & k) = j Next End If End If Next Range("a" & b + 1 & ":b" & k).Borders(xlEdgeTop).LineStyle = xlContinuous Range("a" & b + 1 & ":b" & k).Borders(xlEdgeBottom).LineStyle = xlContinuous Range("a" & b + 1 & ":b" & k).Borders(xlEdgeRight).LineStyle = xlContinuous Range("a" & b + 1 & ":b" & k).Borders(xlEdgeLeft).LineStyle = xlContinuous Range("a" & b + 1 & ":b" & k).Borders(xlInsideVertical).LineStyle = xlContinuous Range("a" & b + 1 & ":b" & k).Borders(xlInsideHorizontal).LineStyle = xlContinuous End If End If Application.ScreenUpdating = True End Sub
[/vba]
не правильно написал(( переделаю позже
исправил [vba]
Код
Sub u_963() Application.ScreenUpdating = False a = Cells(Rows.Count, "a").End(xlUp).Row d = Cells(1, Columns.Count).End(xlToLeft).Column If a > 1 Then b = Application.Match("ÔÈÎ ñòóäåíòà", Range("a2:a" & a), 0) If IsNumeric(b) Then If a > b + 1 Then Range("a" & b + 2 & ":b" & a).Clear For c = 2 To b e = Range("a" & c).Value If e <> "" Then f = Application.Count(Range(Cells(c, 3), Cells(c, d))) If f < d - 2 Then For g = 1 To d - 2 - f s = Cells(c, "c").Address t = Cells(c, d).Address u = s & ":" & t i = Evaluate("=SMALL(IF(" & u & "="""",COLUMN(" & u & "))," & g & ")") j = Cells(1, i).Value k = Cells(Rows.Count, "a").End(xlUp).Row + 1 Range("a" & k) = e Range("b" & k) = j Next End If End If Next Range("a" & b + 1 & ":b" & k).Borders(xlEdgeTop).LineStyle = xlContinuous Range("a" & b + 1 & ":b" & k).Borders(xlEdgeBottom).LineStyle = xlContinuous Range("a" & b + 1 & ":b" & k).Borders(xlEdgeRight).LineStyle = xlContinuous Range("a" & b + 1 & ":b" & k).Borders(xlEdgeLeft).LineStyle = xlContinuous Range("a" & b + 1 & ":b" & k).Borders(xlInsideVertical).LineStyle = xlContinuous Range("a" & b + 1 & ":b" & k).Borders(xlInsideHorizontal).LineStyle = xlContinuous End If End If Application.ScreenUpdating = True End Sub
Если доступа к Excel последних версий нет, то можно попробовать (прямо сейчас!) портироваться в Google Таблицу. Аналогичная формула там будет выглядеть так (при включенном отображении названий функций на английском): [vba]
Если доступа к Excel последних версий нет, то можно попробовать (прямо сейчас!) портироваться в Google Таблицу. Аналогичная формула там будет выглядеть так (при включенном отображении названий функций на английском): [vba]
Sub Макрос3() Dim arr1, y, x, n As Integer, m As Integer, k As Integer lr = Cells(1, 1).CurrentRegion.Rows.Count lr1 = Cells(Rows.Count, 1).End(xlUp).Row arr1 = Range("A1:H" & lr) Set dic = CreateObject("Scripting.Dictionary") k = 0 For n = 2 To UBound(arr1) For m = 3 To UBound(arr1, 2) If arr1(n, m) = "" Then If Not dic.exists(arr1(n, 1)) Then Set dic(arr1(n, 1)) = CreateObject("Scripting.Dictionary") dic(arr1(n, 1)).Add arr1(1, m), arr1(1, m): k = k + 1 End If Next Next ReDim arr1(1 To k, 1 To 2) n = 1 Rows(lr + 3 & ":" & lr1 + 1).Delete Shift:=xlUp For Each y In dic For Each x In dic(y) arr1(n, 1) = y: arr1(n, 2) = x: n = n + 1 Next Next Range("A" & lr + 3).Resize(UBound(arr1), 2) = arr1 End Sub
[/vba] Строка между таблицами должна быть пустой
Ещё вариант макросом [vba]
Код
Sub Макрос3() Dim arr1, y, x, n As Integer, m As Integer, k As Integer lr = Cells(1, 1).CurrentRegion.Rows.Count lr1 = Cells(Rows.Count, 1).End(xlUp).Row arr1 = Range("A1:H" & lr) Set dic = CreateObject("Scripting.Dictionary") k = 0 For n = 2 To UBound(arr1) For m = 3 To UBound(arr1, 2) If arr1(n, m) = "" Then If Not dic.exists(arr1(n, 1)) Then Set dic(arr1(n, 1)) = CreateObject("Scripting.Dictionary") dic(arr1(n, 1)).Add arr1(1, m), arr1(1, m): k = k + 1 End If Next Next ReDim arr1(1 To k, 1 To 2) n = 1 Rows(lr + 3 & ":" & lr1 + 1).Delete Shift:=xlUp For Each y In dic For Each x In dic(y) arr1(n, 1) = y: arr1(n, 2) = x: n = n + 1 Next Next Range("A" & lr + 3).Resize(UBound(arr1), 2) = arr1 End Sub
[/vba] Строка между таблицами должна быть пустойmsi2102
Вход
Регистрация
Напомнить пароль
Автосумма
Часто используемые
ВПР
ЕСЛИ
СУММЕСЛИ
Финансовые
Логические
Текстовые
Даты и времени 
Ссылки и массивы 
Математические
Другие функции
Проверка свойств и значений
Баз данных
Математические
Обработки массивов
Обработки строк
Преобразования типов данных 
Загрузки данных
Работы с файлами
Обработки системных параметров
Обработки цвета
Работы с датами и временем
Преобразования в системы счисления
Финансовые
