Открытие файла и копирование конкретных данных

[Stepashka]

Здравствуйте, форумчане
Помогите, пожалуйста, советом.
Задумка такая:
Открываем файл (Книга1), при выполнение трех условий, отбираем необходимые данные, а затем, копируем их другой файл по столбцам (книга2).

Условия:
1) Содержание слова "форум" в ячейках первого столбца;
2) 13 столбец не должен быть равен значению "Отсутствует";
3) Количество символов 4 столбца менее 25.

Моя "задумка" находит только первое значение и останавливается, причем, отобранные данные переносятся во второй файл многократно - одно и тоже значение.
Понимаю, что, что-то не то с циклом, но что конкретно, не понимаю.

Прошу содействия.

Спасибо.

Код: (vb)

Sub Открытие_и_копия8()

Dim i As Integer
Dim iLastRow As Long

Workbooks.Open Filename:="C:\Users\Книга1.xlsm"

Set List1 = Workbooks("Книга1.xlsm").Sheets("Лист1")
Set List2 = Workbooks("Книга2.xlsm").Sheets("Лист1")

 iLastRow = List1.Cells(Rows.Count, 1).End(xlUp).Row
   For i = 1 To iLastRow
     
        If Cells(i, 1) Like "*Форум*" Then
        If List1.Cells(i, 13).Value <> "Отсутствует" Then
        If Len(List1.Cells(i, 4)) < 25 Then
  Workbooks("Книга2.xlsm").Activate
  ActiveWorkbook.Worksheets("Лист1").Select
 
   List2.Cells(8, 1) = List1.Cells(i, 4)
   List2.Cells(9, 1) = List1.Cells(i, 4)
   List2.Cells(10, 1) = List1.Cells(i, 4)
   List2.Cells(11, 1) = List1.Cells(i, 4)
   List2.Cells(12, 1) = List1.Cells(i, 4)
   List2.Cells(13, 1) = List1.Cells(i, 4)
   List2.Cells(14, 1) = List1.Cells(i, 4)
   List2.Cells(15, 1) = List1.Cells(i, 4)
   List2.Cells(16, 1) = List1.Cells(i, 4)
   List2.Cells(17, 1) = List1.Cells(i, 4)
   List2.Cells(18, 1) = List1.Cells(i, 4)
   List2.Cells(19, 1) = List1.Cells(i, 4)
   
  
   List2.Cells(8, 12) = List1.Cells(i, 4)
   List2.Cells(9, 12) = List1.Cells(i, 4)
   List2.Cells(10, 12) = List1.Cells(i, 4)
   List2.Cells(11, 12) = List1.Cells(i, 4)
   List2.Cells(12, 12) = List1.Cells(i, 4)
   List2.Cells(13, 12) = List1.Cells(i, 4)
   List2.Cells(14, 12) = List1.Cells(i, 4)
   List2.Cells(15, 12) = List1.Cells(i, 4)
   List2.Cells(16, 12) = List1.Cells(i, 4)
   List2.Cells(17, 12) = List1.Cells(i, 4)
   List2.Cells(18, 12) = List1.Cells(i, 4)
   List2.Cells(19, 12) = List1.Cells(i, 4)
   
   End If
   End If
   End If
   
   Next i
   
Workbooks("Книга1.xlsm").Close False

End Sub

[alex77755]

Код: (vb)

iLastRow = List1.Cells(Rows.Count, 1).End(xlUp).Row

правильнее так:

Код: (vb)

iLastRow = List1.Cells(List1.Rows.Count, 1).End(xlUp).Row

многократно - одно и тоже значение

Так что написали, то и выводится: с 8 по 19 строки записывается одно и то же значение  List1.Cells(i, 4)
Причём в 2 колонки. И причём переписывается при каждом выполнении условий

[Stepashka]

Спасибо за ответ.
Немного преобразовала, но результат прежний. В тупике.  Интернет не помог. Поделитесь, пожалуйста, соображениями, как можно реализовать. Спасибо.

Код: (vb)

      

Sub Открытие_и_копия3()
      
    Dim i As Integer
    Dim j As Integer

    Dim iLastRow As Long
      
    Workbooks.Open Filename:="C:\Users\Книга1.xlsm"
      
    Set List1 = Workbooks("Книга1.xlsm").Sheets("Лист1")
    Set List2 = Workbooks("Книга2.xlsm").Sheets("Лист1")
      
     iLastRow = List1.Cells(Rows.Count, 1).End(xlUp).Row
       For i = 1 To iLastRow
        For j = 8 To 19
           
            If Cells(i, 1) Like "*Форум*" Then
            If List1.Cells(i, 13).Value <> "Отсутствует" Then
            If Len(List1.Cells(i, 4)) < 25 Then
      Workbooks("Книга2.xlsm").Activate
      ActiveWorkbook.Worksheets("Лист1").Select
       
       List2.Cells(j, 1) = List1.Cells(i, 4)
       List2.Cells(j, 12) = List1.Cells(i, 4)
                
       End If
       End If
       End If
       
       Next j
       Next i
         
    Workbooks("Книга1.xlsm").Close False
      
    End Sub

[Дмитрий Щербаков(The_Prist)]

1.

Код: (vb)

List2.Cells(j, 1) = List1.Cells(i, 4)
List2.Cells(j, 12) = List1.Cells(i, 4)

в List2 столбцы разные, а значения из List1 попадают из одинаковых столбцов.

2.

Код: (vb)

Workbooks("Книга2.xlsm").Activate  
      ActiveWorkbook.Worksheets("Лист1").Select

уберите, оно не нужно здесь. От слова вообще.

3. Сравнения на "форум" у Вас с привязкой к активному листу и с учетом регистра. Лучше от этого избавиться, пусть без оптимизации, но понятно Вам:

Код: (vb)

If LCase(List1.Cells(i, 1).Value) Like "*форум*" Then  
            If LCase(List1.Cells(i, 13).Value) <> "отсутствует" Then  
            If Len(List1.Cells(i, 4)) < 25 Then 

4. Циклы явно расположены неверно - зачем второй цикл до проверки значений в List1?
5. Тип Integer не лучший выбор при работе со строками. Т.к. его предел 32756, то при попытке записи в строку, превышающую этот предел будет ошибка.
6. Ну и совершенно непонятно, какие в итоге значения должны быть куда записаны.
For j = 8 To 19
т.е. всегда будете записывать данные с 8-ой по 19 строку? Как-то не очень правильно. И всегда только два столбца и значения в них попадают всегда из 1-го...Бред, одним словом. Напишите что куда должно попадать. Тогда можно будет показать код более правильный и более отвечающий требованиям. А пока только так:

Код: (vb)

Sub Открытие_и_копия3()
    Dim i As Long, j As Long
    Dim iLastRow As Long, llastr_2 As Long
        
    Workbooks.Open Filename:="C:\Users\Книга1.xlsm"
    Set List1 = Workbooks("Книга1.xlsm").Sheets("Лист1")
    Set List2 = Workbooks("Книга2.xlsm").Sheets("Лист1")
    iLastRow = List1.Cells(List1.Rows.Count, 1).End(xlUp).Row
    For i = 1 To iLastRow
        If LCase(List1.Cells(i, 1).Value) Like "*форум*" Then
            If LCase(List1.Cells(i, 13).Value) <> "отсутствует" Then
                If Len(List1.Cells(i, 4)) < 25 Then
                    llastr_2 = List2.Cells(List2.Rows.Count, 1).End(xlUp).Row
                    For j = 1 To 11
                        List2.Cells(llastr_2 + j, 1) = List1.Cells(i, 4)
                        List2.Cells(llastr_2 + j, 12) = List1.Cells(i, 4)
                    Next j
                End If
            End If
        End If
    Next i
    Workbooks("Книга1.xlsm").Close False
End Sub

[Stepashka]

Спасибо за содействие, но проблема осталась. Одну и ту же найденную запись прописывает многократно в другую книгу в новую таблицу. Затем находит следующую и снова ее многократно дублирует.

Всегда будете записывать данные с 8-ой по 19 строку?

- Да, данные отбираются из одной общей таблице по трем критериям. Из отобранных записей строится другая таблица. Как то так.

[Дмитрий Щербаков(The_Prist)]

но проблема осталась

А эта проблема никуда не денется, потому что мы не знаем что должно переноситься, а Вы упорно не хотите это нормально объяснить. Я уже писал об этом:

Ну и совершенно непонятно, какие в итоге значения должны быть куда записаны.
For j = 8 To 19
т.е. всегда будете записывать данные с 8-ой по 19 строку? Как-то не очень правильно. И всегда только два столбца и значения в них попадают всегда из 1-го...Бред, одним словом. Напишите что куда должно попадать. Тогда можно будет показать код более правильный и более отвечающий требованиям.

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

[Stepashka]

Каюсь, постараюсь подробнее изложить на простом примере:
Номера выделенные красной заливкой в приложенном файле должный копироваться из Книга1 в Книга2 один раз каждый найденный номер. Отбираться из Книга1 по принципу:
1) Ячейка Столбца 1 (Книга1) содержит слово "форум".
2) Значение ячейки Столбца 4  (Книга1) отличается от слова "отсутствует"
3) Количество символов в ячейке Столбца 3 (Книга1) менее 25
Процесс запускается с кнопки в Книга2.

Как видно из примера (в приложении) последний найденный номер многократно прописан в таблицу Книга2, а должен быть список из всех найденных номеров без дубликатов.

[Дмитрий Щербаков(The_Prist)]

Я может чего не понимаю, но в таком случае достаточно просто убрать цикл в моем последнем коде:

Код: (vb)

For j = 1 To 11  
    List2.Cells(llastr_2 + j, 1) = List1.Cells(i, 4)  
    List2.Cells(llastr_2 + j, 12) = List1.Cells(i, 4)  
Next j 

и вместо него написать так:

Код: (vb)

List2.Cells(llastr_2 + 1, 1) = List1.Cells(i, 4)
List2.Cells(llastr_2 + 1, 2) = List1.Cells(i, 4)

Тогда копироваться будет один раз. Правда, один и тот же номер в два столбца - но по этому поводу Вы никаких пояснений не даете...
Ну и не очень понятно - изначально номера столбцов были другие. И не понял, зачем Вы удалили мою строку, где последняя заполненная ячейка в итоговой книге определялась. Без неё поиск вообще теряет смысл, т.к. значения всегда записываются начиная с 1-ой строки. В общем, если опираться на приложенные файлы, то код должен выглядеть как-то так:

Код: (vb)

Sub Открытие_и_копия3()
    Dim i As Long, j As Long
    Dim iLastRow As Long, llastr_2 As Long
          
    Workbooks.Open Filename:="C:\Users\Администратор\Desktop\Пример\Книга1.xlsm"
    Set List1 = Workbooks("Книга1.xlsm").Sheets("Лист1")
    Set List2 = Workbooks("Книга2.xlsm").Sheets("Лист1")
    iLastRow = List1.Cells(List1.Rows.Count, 1).End(xlUp).Row
    For i = 2 To iLastRow
        If LCase(List1.Cells(i, 1).Value) Like "*форум*" Then
            If LCase(List1.Cells(i, 4).Value) <> "отсутствует" Then
                If Len(List1.Cells(i, 3)) < 25 Then
                    llastr_2 = List2.Cells(List2.Rows.Count, 1).End(xlUp).Row
                    List2.Cells(llastr_2 + 1, 1).Value = List1.Cells(i, 2).Value
                    List2.Cells(llastr_2 + 1, 2).Value = List1.Cells(i, 2).Value
                End If
            End If
        End If
    Next i
    Workbooks("Книга1.xlsm").Close False
End Sub

[Stepashka]

Спасибо огромное! пробую....

Правда, один и тот же номер в два столбца - но по этому поводу Вы никаких пояснений не даете...

Несколько столбцов нужны т.к. количество отобранных номеров будет большим, но, разумеется, в каждом столбце разные значения.

[Stepashka]

Я, конечно дико извиняюсь, но никак не получается сделать, чтобы найденные значения выстраивались в несколько колонок с 8 по 19 строку. Ориентироваться на последнюю заполненную строку не могу, т.к. и сверху и снизу итоговой таблицы содержится текст. А найденные номера, как бы "вклиниваются" в середину таблицы.
Например: найдено 37 значений (см. Пример 2), все найденные числа в итоговую таблицу прописываются только один раз, и выстраиваются с 8 по 19 строку в несколько столбцов.
Спасибо.

[Дмитрий Щербаков(The_Prist)]

в несколько колонок с 8 по 19 строку

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

[Дмитрий Щербаков(The_Prist)]

В общем, если правильно понял, то такой код точно должен помочь(если структура, показанная на скрине совпадает с реальностью):

Код: (vb)

Sub Открытие_и_копия3()
    Dim i As Long, j As Long
    Dim iLastRow As Long, llastr_2 As Long, lres_col As Long
          
    Workbooks.Open Filename:="C:\Users\Администратор\Desktop\Пример\Книга1.xlsm"
    Set List1 = Workbooks("Книга1.xlsm").Sheets("Лист1")
    Set List2 = Workbooks("Книга2.xlsm").Sheets("Лист1")
    iLastRow = List1.Cells(List1.Rows.Count, 1).End(xlUp).Row
    lres_col = 1
    For i = 2 To iLastRow
        If LCase(List1.Cells(i, 1).Value) Like "*форум*" Then
            If LCase(List1.Cells(i, 4).Value) <> "отсутствует" Then
                If Len(List1.Cells(i, 3)) < 25 Then
                    llastr_2 = List2.Cells(20, lres_col).End(xlUp).Row
                    If llastr_2 < 7 Then
                        lres_col = lres_col + 1
                        llastr_2 = 7
                    End If
                    List2.Cells(llastr_2 + 1, lres_col).Value = List1.Cells(i, 2).Value
                End If
            End If
        End If
    Next i
    Workbooks("Книга1.xlsm").Close False
End Sub

[Stepashka]

Дмитрий, спасибо большое, все получилось.