Страницы: 1
RSS
Копирование строк в лист из другого листа при условии, непонятная ошибка в коде
 
Добрый вечер всем,
Есть Лист-опросник (Да/нет)
Лист, куда необходимо по кнопке на нем скопировать все строки с листа-опросника, ответ на которые составляет "Да"
Друг за другом, начиная с первой пустой строки после шапки
Посмотрите код, плз - где-то ошибка( выдает ошибку в строке " b(r,1) = a(i, 1), пишет b(r,1) out of range)
Код

Блок стилей "STYLE"


Sub Rectangle2_Click()


Dim a() As Variant, b() As Variant, c() As Variant, i As Long, r As Long, iLastRow1 As Long, iLastRow2 As Long, nRow1 As Long, nRow2 As Long
    nRow1 = 6 'строка начала данных на листе Risk Taxonomy
    nRow2 = 6 'строка начала данных на листе Risk Identification
    
    iLastRow1 = ActiveWorkbook.Sheets("Risk Taxonomy").Cells(Rows.Count, "B").End(xlUp).Row 'поиск номера последней незаполненной ячейки
    iLastRow2 = ActiveWorkbook.Sheets("Risk Identification").Cells(Rows.Count, "B").End(xlUp).Row
    a = ActiveWorkbook.Sheets("Risk Taxonomy").Range("B" & nRow1 & ":N" & iLastRow1).Value
    ActiveWorkbook.Sheets("Risk Identification").Range("B" & nRow2 & ":N400" & iLastRow2).Value = ""
    b = ActiveWorkbook.Sheets("Risk Identification").Range("B" & nRow2 & ":N" & iLastRow2).Value
    r = 1
    For i = 1 To iLastRow1 - nRow1
      If a(i, 13) = "Yes" Then
      b(r, 1) = a(i, 1)
      b(r, 2) = a(i, 2)
      b(r, 3) = a(i, 3)
      r = r + 1
      End If
    Next i
      
    ActiveWorkbook.Sheets("Risk Identification").Range("B" & nRow2 & ":F" & iLastRow2).Value = b
    ActiveWorkbook.Sheets("Risk Identification").Range("B" & nRow2 & ":F" & iLastRow2).Select
    Selection.Borders.LineStyle = xlContinuous


End Sub


 
peter335, добрый вечер! Кажется, Вы что-то не договариваете, скрываете (файл, например)...  
 
Извините, впервые создал тему на форуме!
Буду очень признателен за помощь!
 
peter335,
Код
[/Sub aaa()
Dim aa As Range, a&, c&, bb As Range, sh1 As Worksheet, sh2 As Worksheet
Set sh1 = Sheets(1): Set sh2 = Sheets(2)
If Len(sh2.[B6]) > 0 Then Intersect(sh2.Rows("6:" & sh2.Cells(sh2.Rows.Count, "B").End(xlUp).Row), sh2.Columns("B:D")).Clear
Set aa = Intersect(sh1.Rows("6:" & sh1.Cells(sh1.Rows.Count, "B").End(xlUp).Row), sh1.Columns("B:D"))
For a = 1 To aa.Rows.Count
  If aa(a, 1).EntireRow.Columns("N") = "Yes" Then
    If c = 0 Then
      Set bb = aa.Rows(a): c = 1
    Else: Set bb = Union(bb, aa.Rows(a))
    End If
  End If
Next
If Not bb Is Nothing Then bb.Copy sh2.[B6]
End Sub
Изменено: Anchoret - 25.02.2019 01:14:20
Страницы: 1
Наверх