Домашняя страница Undo Do New Save Карта сайта Обратная связь Поиск по форуму
МИР MS EXCEL - Гость.xls

Вход

Регистрация

Напомнить пароль

 

= Мир MS Excel/Перебор заполненных ячеек в диапазоне, начиная со второй - Мир MS Excel

Регистрация · Логин: · Пароль: · · Забыли пароль?
  • Страница 1 из 1
  • 1
Модератор форума: _Boroda_, Manyasha, SLAVICK, китин  
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Перебор заполненных ячеек в диапазоне, начиная со второй (Макросы/Sub)
Перебор заполненных ячеек в диапазоне, начиная со второй
StoTisteg Дата: Пятница, 07.12.2018, 13:04 | Сообщение № 1
Группа: Авторы
Ранг: Старожил
Сообщений: 1101
Репутация: 100 ±
Замечаний: 0% ±

Excel 2010
Коллеги, что-то я никак не победю и не побежду 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]Нет ли каких-нибудь идей, как без неё обойтись?
К сообщению приложен файл: FillEnum.xlsm(17.4 Kb)


Интуитивно понятный код - это когда интуитивно понятно, что это код.

Сообщение отредактировал StoTisteg - Пятница, 07.12.2018, 13:06
 
Ответить
СообщениеКоллеги, что-то я никак не победю и не побежду 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
Дата добавления - 07.12.2018 в 13:04
_Boroda_ Дата: Пятница, 07.12.2018, 14:27 | Сообщение № 2
Группа: Модераторы
Ранг: Местный житель
Сообщений: 13698
Репутация: 5587 ±
Замечаний: 0% ±

2003; 2007; 2010; 2013 RUS
Так нужно?
[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
[/vba]


Скажи мне, кудесник, любимец ба’гов...
Платная помощь:
Boroda_Excel@mail.ru
Яндекс-деньги: 41001632713405 | Webmoney: R289877159277; Z102172301748; E177867141995
 
Ответить
СообщениеТак нужно?
[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
[/vba]

Автор - _Boroda_
Дата добавления - 07.12.2018 в 14:27
StoTisteg Дата: Пятница, 07.12.2018, 15:32 | Сообщение № 3
Группа: Авторы
Ранг: Старожил
Сообщений: 1101
Репутация: 100 ±
Замечаний: 0% ±

Excel 2010
_Boroda_, увы, не так. Первая дата не обязана быть во второй строке, она может быть вообще в любой, хоть в предпоследней. Например, так. Но и в этом случае нам нужны все даты, кроме первой.
К сообщению приложен файл: 4958362.xlsm(18.9 Kb)


Интуитивно понятный код - это когда интуитивно понятно, что это код.
 
Ответить
Сообщение_Boroda_, увы, не так. Первая дата не обязана быть во второй строке, она может быть вообще в любой, хоть в предпоследней. Например, так. Но и в этом случае нам нужны все даты, кроме первой.

Автор - StoTisteg
Дата добавления - 07.12.2018 в 15:32
_Boroda_ Дата: Пятница, 07.12.2018, 15:39 | Сообщение № 4
Группа: Модераторы
Ранг: Местный житель
Сообщений: 13698
Репутация: 5587 ±
Замечаний: 0% ±

2003; 2007; 2010; 2013 RUS
Так?
[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
[/vba]
К сообщению приложен файл: 4958362_1.xlsm(15.4 Kb)


Скажи мне, кудесник, любимец ба’гов...
Платная помощь:
Boroda_Excel@mail.ru
Яндекс-деньги: 41001632713405 | Webmoney: R289877159277; Z102172301748; E177867141995
 
Ответить
СообщениеТак?
[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
[/vba]

Автор - _Boroda_
Дата добавления - 07.12.2018 в 15:39
StoTisteg Дата: Пятница, 07.12.2018, 16:12 | Сообщение № 5
Группа: Авторы
Ранг: Старожил
Сообщений: 1101
Репутация: 100 ±
Замечаний: 0% ±

Excel 2010
Ага, спасибо. Я с Вашей помощью и знанием, что Cells(1) определяется верно другой вариант придумал:[vba]
Код
Sub test4()

   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)
   rws = zap.Cells(1).Row + 1
   Set zap = shc.Range(shc.Cells(rws, 3), shc.Cells(rwf, 5)).SpecialCells(xlCellTypeConstants)
   For Each cell In zap
      i = i + 1
      shw.Cells(i + 1, 1).Value = chc.Cells(cell.Row, 2).Value
      shw.Cells(i + 1, 2).Value = cell.Value
   Next cell

End Sub
[/vba]


Интуитивно понятный код - это когда интуитивно понятно, что это код.

Сообщение отредактировал StoTisteg - Пятница, 07.12.2018, 16:13
 
Ответить
СообщениеАга, спасибо. Я с Вашей помощью и знанием, что Cells(1) определяется верно другой вариант придумал:[vba]
Код
Sub test4()

   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)
   rws = zap.Cells(1).Row + 1
   Set zap = shc.Range(shc.Cells(rws, 3), shc.Cells(rwf, 5)).SpecialCells(xlCellTypeConstants)
   For Each cell In zap
      i = i + 1
      shw.Cells(i + 1, 1).Value = chc.Cells(cell.Row, 2).Value
      shw.Cells(i + 1, 2).Value = cell.Value
   Next cell

End Sub
[/vba]

Автор - StoTisteg
Дата добавления - 07.12.2018 в 16:12
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Перебор заполненных ячеек в диапазоне, начиная со второй (Макросы/Sub)
  • Страница 1 из 1
  • 1
Поиск:

Яндекс цитирования
© 2010-2018 · Дизайн: MichaelCH · Хостинг от uCoz · При использовании материалов сайта, ссылка на www.excelworld.ru обязательна!