Коллеги, что-то я никак не победю и не побежду CpecialCells... Есть список исполнителей по задаче (Колонка 2 на листе 1) и список возможных действий (строка заголовков на нём же). На пересечении может стоять отметка об исполнении действия (дата) (а может не стоять), максимум одно действие на исполнителя. Задача следующая. Необходимо, начиная со второй заполненной строки (то есть со второй строки, где есть отметка) перенести на другой лист имена исполнителей и даты (как показано на листе 2). Напрашивается перебор заполненных ячеек с помощью CpecialCells по индексу ячейки:[vba]
Код
Sub test()
Dim rws As Integer, rwf As Integer, i As Integer Dim shc As Worksheet, shw As Worksheet Dim zap As Range, cell As Range
Set shc = Worksheets(1) Set shw = Worksheets(2) rws = shc.Cells(Rows.Count, 1).End(xlUp).Row rwf = shc.Cells(Rows.Count, 2).End(xlUp).Row Set zap = shc.Range(shc.Cells(rws, 3), shc.Cells(rwf, 5)).SpecialCells(xlCellTypeConstants) For i = 2 To zap.Cells.Count shw.Cells(i + 1, 1).Value = shc.Cells(zap.Cells(i).Row, 2).Value shw.Cells(i + 1, 2).Value = zap.Cells(i).Value Next i
End Sub
[/vba]Проблема в том, что этот код перебирает не заполненные ячейки, а нечто совершенно случайное и левое... Решение с промежуточной UDT-переменной, заполняемой циклом For Each, который работает корректно, кажется мне слишком громоздким:[vba]
Код
Type sStrings sName As Collection dat1 As Collection dat2 As Collection dat3 As Collection End Type
Sub test2()
Dim rws As Integer, rwf As Integer, i As Integer Dim shc As Worksheet, shw As Worksheet Dim zap As Range, cell As Range Dim sString As sStrings
Set shc = Worksheets(1) Set shw = Worksheets(2) rws = shc.Cells(Rows.Count, 1).End(xlUp).Row rwf = shc.Cells(Rows.Count, 2).End(xlUp).Row Set zap = shc.Range(shc.Cells(rws, 3), shc.Cells(rwf, 5)).SpecialCells(xlCellTypeConstants) With sString Set .sName = New Collection Set .dat1 = New Collection Set .dat2 = New Collection Set .dat3 = New Collection For Each cell In zap .sName.Add shc.Cells(cell.Row, 2).Value .dat1.Add shc.Cells(cell.Row, 3).Value .dat2.Add shc.Cells(cell.Row, 4).Value .dat3.Add shc.Cells(cell.Row, 5).Value Next cell For i = 2 To .sName.Count shw.Cells(i, 1).Value = .sName(i) If .dat1(i) <> "" Then shw.Cells(i, 2).Value = .dat1(i) If .dat2(i) <> "" Then shw.Cells(i, 2).Value = .dat2(i) If .dat3(i) <> "" Then shw.Cells(i, 2).Value = .dat3(i) Next i End With
End Sub
[/vba]Нет ли каких-нибудь идей, как без неё обойтись?
Коллеги, что-то я никак не победю и не побежду CpecialCells... Есть список исполнителей по задаче (Колонка 2 на листе 1) и список возможных действий (строка заголовков на нём же). На пересечении может стоять отметка об исполнении действия (дата) (а может не стоять), максимум одно действие на исполнителя. Задача следующая. Необходимо, начиная со второй заполненной строки (то есть со второй строки, где есть отметка) перенести на другой лист имена исполнителей и даты (как показано на листе 2). Напрашивается перебор заполненных ячеек с помощью CpecialCells по индексу ячейки:[vba]
Код
Sub test()
Dim rws As Integer, rwf As Integer, i As Integer Dim shc As Worksheet, shw As Worksheet Dim zap As Range, cell As Range
Set shc = Worksheets(1) Set shw = Worksheets(2) rws = shc.Cells(Rows.Count, 1).End(xlUp).Row rwf = shc.Cells(Rows.Count, 2).End(xlUp).Row Set zap = shc.Range(shc.Cells(rws, 3), shc.Cells(rwf, 5)).SpecialCells(xlCellTypeConstants) For i = 2 To zap.Cells.Count shw.Cells(i + 1, 1).Value = shc.Cells(zap.Cells(i).Row, 2).Value shw.Cells(i + 1, 2).Value = zap.Cells(i).Value Next i
End Sub
[/vba]Проблема в том, что этот код перебирает не заполненные ячейки, а нечто совершенно случайное и левое... Решение с промежуточной UDT-переменной, заполняемой циклом For Each, который работает корректно, кажется мне слишком громоздким:[vba]
Код
Type sStrings sName As Collection dat1 As Collection dat2 As Collection dat3 As Collection End Type
Sub test2()
Dim rws As Integer, rwf As Integer, i As Integer Dim shc As Worksheet, shw As Worksheet Dim zap As Range, cell As Range Dim sString As sStrings
Set shc = Worksheets(1) Set shw = Worksheets(2) rws = shc.Cells(Rows.Count, 1).End(xlUp).Row rwf = shc.Cells(Rows.Count, 2).End(xlUp).Row Set zap = shc.Range(shc.Cells(rws, 3), shc.Cells(rwf, 5)).SpecialCells(xlCellTypeConstants) With sString Set .sName = New Collection Set .dat1 = New Collection Set .dat2 = New Collection Set .dat3 = New Collection For Each cell In zap .sName.Add shc.Cells(cell.Row, 2).Value .dat1.Add shc.Cells(cell.Row, 3).Value .dat2.Add shc.Cells(cell.Row, 4).Value .dat3.Add shc.Cells(cell.Row, 5).Value Next cell For i = 2 To .sName.Count shw.Cells(i, 1).Value = .sName(i) If .dat1(i) <> "" Then shw.Cells(i, 2).Value = .dat1(i) If .dat2(i) <> "" Then shw.Cells(i, 2).Value = .dat2(i) If .dat3(i) <> "" Then shw.Cells(i, 2).Value = .dat3(i) Next i End With
End Sub
[/vba]Нет ли каких-нибудь идей, как без неё обойтись?StoTisteg
Sub test() Dim rws As Integer, rwf As Integer, i As Integer Dim shw As Worksheet Dim zap As Range, d As Range Set shw = Worksheets(2) With Worksheets(1) rws = .Cells(.Rows.Count, 1).End(xlUp).Row rwf = .Cells(.Rows.Count, 2).End(xlUp).Row Set zap = .Range(.Cells(rws + 1, 3), .Cells(rwf, 5)).SpecialCells(xlCellTypeConstants) For Each d In zap i = i + 1 shw.Cells(i + 1, 1).Value = .Cells(d.Row, 2).Value shw.Cells(i + 1, 2).Value = d.Value Next d End With End Sub
[/vba]
Так нужно? [vba]
Код
Sub test() Dim rws As Integer, rwf As Integer, i As Integer Dim shw As Worksheet Dim zap As Range, d As Range Set shw = Worksheets(2) With Worksheets(1) rws = .Cells(.Rows.Count, 1).End(xlUp).Row rwf = .Cells(.Rows.Count, 2).End(xlUp).Row Set zap = .Range(.Cells(rws + 1, 3), .Cells(rwf, 5)).SpecialCells(xlCellTypeConstants) For Each d In zap i = i + 1 shw.Cells(i + 1, 1).Value = .Cells(d.Row, 2).Value shw.Cells(i + 1, 2).Value = d.Value Next d End With End Sub
_Boroda_, увы, не так. Первая дата не обязана быть во второй строке, она может быть вообще в любой, хоть в предпоследней. Например, так. Но и в этом случае нам нужны все даты, кроме первой.
_Boroda_, увы, не так. Первая дата не обязана быть во второй строке, она может быть вообще в любой, хоть в предпоследней. Например, так. Но и в этом случае нам нужны все даты, кроме первой.StoTisteg
Sub test() Dim rws As Integer, rwf As Integer, i As Integer Dim shw As Worksheet Dim zap As Range, d As Range Set shw = Worksheets(2) With Worksheets(1) rws = .Cells(.Rows.Count, 1).End(xlUp).Row rwf = .Cells(.Rows.Count, 2).End(xlUp).Row Set zap = .Range(.Cells(rws, 3), .Cells(rwf, 5)).SpecialCells(xlCellTypeConstants) For Each d In zap i = i + 1 If i > 1 Then shw.Cells(i, 1).Value = .Cells(d.Row, 2).Value shw.Cells(i, 2).Value = d.Value End If Next d End With End Sub
[/vba]
Так? [vba]
Код
Sub test() Dim rws As Integer, rwf As Integer, i As Integer Dim shw As Worksheet Dim zap As Range, d As Range Set shw = Worksheets(2) With Worksheets(1) rws = .Cells(.Rows.Count, 1).End(xlUp).Row rwf = .Cells(.Rows.Count, 2).End(xlUp).Row Set zap = .Range(.Cells(rws, 3), .Cells(rwf, 5)).SpecialCells(xlCellTypeConstants) For Each d In zap i = i + 1 If i > 1 Then shw.Cells(i, 1).Value = .Cells(d.Row, 2).Value shw.Cells(i, 2).Value = d.Value End If Next d End With End Sub
Вход
Регистрация
Напомнить пароль
Автосумма
Часто используемые
ВПР
ЕСЛИ
СУММЕСЛИ
Финансовые
Логические
Текстовые
Даты и времени 
Ссылки и массивы 
Математические
Другие функции
Проверка свойств и значений
Баз данных
Математические
Обработки массивов
Обработки строк
Преобразования типов данных 
Загрузки данных
Работы с файлами
Обработки системных параметров
Обработки цвета
Работы с датами и временем
Преобразования в системы счисления
Финансовые
