[[20170512222529]] 『条件を検索して行を追加するVBA』(欄) ページの最後に飛ぶ

[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]

 

『条件を検索して行を追加するVBA』(欄)

初めまして。
A3から下へ10行感覚で数字が入力されています。
各10行の中で、数字は5つまでとしたいのですが、6つ以上入力されていた場合、6つ目以降を次の10行へ持っていきたいです。

(例)

      A
1     
2     
3     4
4     5
5     6
6     3
7     1
8     9
9
10
11
12
13    2
14    8
15    7
16
17
18
19
20
21
22
23    10
24    19
25    14

ここでマクロ実行した場合、A8にある数「9」をA13へ持っていき、A13にある「2」以降をA23〜と言うように10行感覚をズラしていきたいです。
どのようなマクロを組めばよいでしょうか。

< 使用 Excel:Excel2013、使用 OS:Windows7 >


そのものではないですが、参考程度に考えてください。

 Option Explicit

 Sub test()
    Dim i As Long
    Dim n As Long

    For i = 3 To Cells(Rows.Count, "A").End(xlUp).Row Step 10
        With Cells(i, "A")
            If .Offset(5).Value <> "" Then
                .Resize(5).Copy Cells(3, "B").Offset(n)
                n = n + 10
                .Offset(5).Resize(5).Copy Cells(3, "B").Offset(n)
            Else
                .Resize(10).Copy Cells(3, "B").Offset(n)
            End If
        End With
        n = n + 10
    Next

 End Sub

(マナ) 2017/05/12(金) 23:19


Sub main()
    Dim r1 As Range, r2 As Range
    Columns("B:B").Insert Shift:=xlToRight
    Set r1 = Range("A3:A7")
    Set r2 = Range("B3:B7")
    Do
        r2.Value = r1.Value
        If r1.Cells(1).Value <> "" Then Set r2 = r2.Offset(10)
        Set r1 = r1.Offset(5)
    Loop Until r1.Row > Range("A" & Rows.Count).End(xlUp).Row
    Columns("A:A").Delete Shift:=xlToLeft
End Sub
(mm) 2017/05/15(月) 10:03

Sub main() '修正
    Dim r1 As Range, r2 As Range, c As Range
    Columns("B:B").Insert Shift:=xlToRight
    Set r1 = Range("A3:A7")
    Set r2 = Range("B3:B7")
    Do
        r2.Value = r1.Value
            For Each c In r1
                If c.Value <> "" Then Set r2 = r2.Offset(10): Exit For
            Next c
        Set r1 = r1.Offset(5)
    Loop Until r1.Row > Range("A" & Rows.Count).End(xlUp).Row
    Columns("A:A").Delete Shift:=xlToLeft
End Sub
(mm) 2017/05/15(月) 10:35

コメント返信:

[ 一覧(最新更新順) ]


YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki. Modified by kazu.