Макрос, который ищет значения 1 в столбце и вставляет скопир.ячейки напротив 1.

Автор GoodPaul, 27.04.2014, 19:49

« назад - далее »

GoodPaul

 Задача следующая: есть столбец в котором через определенные НЕравные промежутки повторятеся цифра 1. Также есть формулы, которые должны располагаться в соседних ячейках от цифры 1. Нужен макрос, который бы копировал формулы из диапазона (к примеру F18:I67) и вставлял напротив каждой найденной цифры 1 (которые находится например в столбце AH).

Сам сделал макрос через простые команды If, но кол-во ячеек в которых может появиться цифра 1 доходит до 4000 строки, так что он очень громоздкий.
Sub macros1()
    Range("F18:I67").Select
    Selection.Copy
   If Range("AH101") = 1 Then Range("AD101").Select
   ActiveSheet.Paste
   If Range("AH102") = 1 Then Range("AD102").Select
   ActiveSheet.Paste
   If Range("AH103") = 1 Then Range("AD103").Select
   ActiveSheet.Paste
и т.д. до AH4000

cheshiki1

изучите циклы.
Sub macros1()
Dim i&
Dim L As Long
L = Cells(Rows.Count, 34).End(xlUp).Row ' номер последней заполненной ячейки столбца АН
For i = 1 To L
If Cells(i, 34) = 1 Then
....
Next
End Sub

код не дописан т.к. не понял зачем вставлять весь диапазон F18:I67 (как у вас в коде) или конкретно какую строку из диапазона вставлять нужно.

GoodPaul

Цитата: cheshiki1 от 27.04.2014, 20:56
код не дописан т.к. не понял зачем вставлять весь диапазон F18:I67 (как у вас в коде) или конкретно какую строку из диапазона вставлять нужно.

СПАСИБО! Это уже лучше, чем 4000 строк кода)). Уточню, диапазон вставлять нужно весь (он всегда один и тот же, т.е. в данном случае F18:I67) и каждый раз напротив очередной ячейки со значением 1. Если можно опишите как закончить код, чтобы напротив всех единиц в столбце AH вставлялся диапазон F18:I67.

cheshiki1

If Cells(i, 34) = 1 Then
Range("F18:I67").Copy
Cells(i, 30).PasteSpecial 'или Cells(i, 34).Offset(0,-4).PasteSpecial
end if
Next

пробуйте

GoodPaul


Hugo121

Так будет побыстрее. Всёж 4000 обещано :(

Sub macros2()
    Dim a(), b(), i&
    a = Range([AH1], Range("AH" & Rows.Count).End(xlUp)).Value
    b = Range("F18:I67").Value
    For i = 1 To UBound(a)
        If a(i, 1) = 1 Then Cells(i, 30).Resize(UBound(b), UBound(b, 2)) = b
    Next
End Sub
webmoney: E265281470651 Z422237915069

GoodPaul

Просто нет слов, одни эмоции. Спасибо, теперь вообще летает))))