Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1
RSS
Скопировать ячейки с каждой 5-й строки одного столбца в соседний.
 
#1
23.08.2017 08:21:30
Дорогие форумчане, подскажите пожалуйста где у меня ошибка. Вроде все делаю по правилам и логике как у всех но почему то не работает.
Код
Sub CopyNames()
    Application.ScreenUpdating = False
    Dim i, k As Long
    
    For i = 4 To n
        For k = 1 To n
            shm.Cells(k, 2) = shm.Cells(i, 1)
        Next k
        i = i + 4
    Next i
    Application.ScreenUpdating = True
End Sub

Есть два столбца

Начиная с 4 строки каждую пятую строку надо скопировать в столбец B.

         А                                      B
1                                      Градусник
2                                      Сироп
3                                      Пюре
4   Градусник                  Настойка
5
6
7
8
9   Сироп
10
11
12
14  Пюре
15
16
17
18
19   Настойка
Изменено: bekzus - 23.08.2017 08:23:00
 
 
 
#2
23.08.2017 08:35:25
Где переменная n берет значение? Второй цикл только мешает

Код
Sub CopyNames()
Dim lRw As Long
Dim i As Long, k As Long
    Application.ScreenUpdating = False
    
    With shm
        lRw = .Cells(.Rows.Count, 1).End(xlUp).Row
    
        For i = 4 To lRw Step 5
            k = k + 1
            .Cells(k, 2).Value = .Cells(i, 1).Value
        Next i
    End With
    
    Application.ScreenUpdating = True
End Sub
 
 
 
#3
23.08.2017 08:35:46
А если добавить в цикл Step?
"..Сладку ягоду рвали вместе, горьку ягоду я одна."
 
 
 
#4
23.08.2017 08:38:20
ну разве она сама не должна вычисляться как lastrow?
 
 
 
#5
23.08.2017 08:38:48
Код
Sub CopyNames()
    Application.ScreenUpdating = False
    Dim i As Long
    n = Cells(Rows.Count, 1).End(xlUp).Row
    k = 1
    For i = 4 To n Step 5
            shm.Cells(k, 2) = shm.Cells(i, 1)
    k = k + 1
    Next i
    Application.ScreenUpdating = True
End Sub
1) У вас не определялась переменная n
2) Зачем 2 цикла ?
3) Вот это i=i+4 вообще не понятно к чему ))
Изменено: Александр П. - 23.08.2017 08:42:00
 
 
 
#6
23.08.2017 08:42:56
Работает! Спасибо Александр. Просто таких наименований 1000. Значит Step 5.
Изменено: bekzus - 23.08.2017 19:48:02
 
 
 
#7
23.08.2017 08:43:00
А без цикла?
Код
lstr = Cells(Rows.Count, 1).End(xlUp).Row
    Range("A1:A" & lstr).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
"..Сладку ягоду рвали вместе, горьку ягоду я одна."
 
 
 
#8
23.08.2017 08:47:35
Цитата
bekzus написал: Работает!
Сообщение №2 :)
 
 
 
#9
23.08.2017 08:53:47
Код
Sub www()
Columns(1).SpecialCells(2).Copy
[b1].PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=True, Transpose:=False
End Sub
 
 
 
#10
23.08.2017 08:57:48
Код
Sub Больше_Сокращать_нечего()
Columns(1).SpecialCells(2).Copy
[b1].PasteSpecial SkipBlanks:=1
End Sub
 
 
 
#11
23.08.2017 09:02:59
k61, Есть чего )))))))
Код
Sub CopyNames()
Columns(1).SpecialCells(2).Copy [B1]
End Sub
Изменено: Александр П. - 23.08.2017 09:03:53
 
 
 
#12
23.08.2017 09:09:20
:)  
 
 
 
#13
23.08.2017 09:34:23
Подразумеваю, что промежуточные строки могут быть не пустыми (пример автора упрощен), Просто информация из этих ячеек не нужна...
Чем шире угол зрения, тем он тупее.
 
 
 
#14
23.08.2017 19:52:32
Vikttur! Я Ваш ответ почему то не увидела. Получается вы первый дали ответ. Спасибо большое!
 
 
 
#15
23.08.2017 19:57:47
Цитата
SAS888 написал:
Подразумеваю, что промежуточные строки могут быть не пустыми (пример автора упрощен), Просто информация из этих ячеек не нужна...

Вы абсолютно правы. Там есть данные
 
 
 
#16
24.08.2017 16:37:16
А есть возможность этот код использовать для Worksheet_Change? Типа
Код
Private Sub Worksheet_Change(ByVal Target As Range)
   'Do nothing if more than one cell is changed or content deleted
    If Target.Cells.Count > 1 Or IsEmpty(Target) Then Exit Sub

    On Error Resume Next
    Application.EnableEvents = False
    Application.ScreenUpdating = False

    Dim i As Long

    n = shm.Cells(shm.Rows.Count, 1).End(xlUp).Row
    For i = 4 To n Step 5
        If shm.Cells(i, 1) = Target.Address Then MsgBox Target.Address
    Next i

    Application.ScreenUpdating = True
    Application.EnableEvents = True
    On Error GoTo 0
End Sub
или нужно только прописывать конкретно адрес?
Изменено: bekzus - 24.08.2017 16:38:00
 
 
 
#17
24.08.2017 16:42:30
Цитата
bekzus написал:
Вы абсолютно правы. Там есть данные
Вроде не блондинка, а пример, как у неё.  
"..Сладку ягоду рвали вместе, горьку ягоду я одна."
 
 
 
#18
24.08.2017 16:44:02
Оказывается можно. Нашла ошибку сама. Нужно добавить address
Код
If shm.Cells(i, 1).address = Target.Addres
 
 
 
#19
25.08.2017 02:41:01
Цитата
bekzus написал:
Там есть данные
Какого типа там данные?
--------------------------------------
Пробник макроса из сообщения #16:
Код
Private Sub Worksheet_Change(ByVal Target As Range)
With Target
If .Count > 1 Or IsEmpty(.Value) Then Exit Sub
If Fix((.Row - 4) / 5) = (.Row - 4) / 5 Then MsgBox .Address
End With
End Sub
 
 
 
Страницы: 1
Наверх