[[20140728131508]] 『空白行挿入とコピー』(バドファン) ページの最後に飛ぶ

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

 

『空白行挿入とコピー』(バドファン)

任意の行列に文字が有ります、印刷の関係で4列までで、5から8列の範囲内に右端が有れば1行下に空白行を1行挿入して1〜4列の下に5〜8列の文字をコピー、9〜12列の間ならさらに又1行空白行を挿入してその行に9〜12列をコピー、それ以上なら又下にコピーとなります。
(5〜8の間なら空白行1行挿入、9〜12列の間なら又1行挿入(計2行)、13〜16行の間なら又1行空白行挿入(計3行)−−−−


a b c d e f g h i j k l m n

次の様に5〜8列を挿入した行の1〜4列にコピー、9〜12列をその下の1〜4列にコピーーーーー

1 2 3 4列
a b c d
e f g h
i j k l
m n

(文字の有る最初の列は一定)数百行有り

宜しくお願いします。

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


とりあえず、別の場所に書き出しています

 Sub test()
    Dim v
    Dim vv() As String
    Dim n As Long
    Dim i As Long
    Dim s As String

    v = Range("A1:A10").Value   '★データ範囲

    For i = 1 To UBound(v)
        s = v(i, 1)
        ReDim Preserve vv(1 To n + Len(s) / 4 + 1)
        Do
            n = n + 1
            vv(n) = Left(s, 4)
            s = Mid(s, 5)
        Loop While Len(s) > 0
    Next

    Columns("D").ClearContents
    Range("D1").Resize(n).Value = WorksheetFunction.Transpose(vv)

 End Sub

(マナ) 2014/07/28(月) 20:56


すいません例題の出し方が不明瞭でした、修正しました。

(バドファン) 2014/07/28(月) 21:20


 こんなこと?

 Sub test()
    Dim a, i As Long, ii As Long
    a = Cells(1).CurrentRegion.Value
    If UBound(a, 2) < 5 Then Exit Sub
    ReDim Preserve a(1 To UBound(a, 1), 1 To Application.Floor(UBound(a, 2) + 4, 5))
    With CreateObject("System.Collections.ArrayList")
        For i = 1 To UBound(a, 1)
            For ii = 1 To UBound(a, 2) Step 5
                .Add Application.Index(a, i, Evaluate("transpose(row(" & ii & ":" & ii + 4 & "))"))
            Next
        Next
        Sheets.Add.Cells(1).Resize(.Count, 5).Value = Application.Index(.ToArray, 0, 0)
    End With
End Sub
(seiya) 2014/07/29(火) 11:25 (チョイ変更)

(書き直します)

(マナ) 2014/07/29(火) 22:02


とりあえず、別シートに書き出しています。
 (ほとんど書き直せませんでした。今日はここまで)

 Sub test2()
    Dim r As Range
    Dim v() As String
    Dim x As Long
    Dim m As Long, n As Long
    Dim i As Long

    For Each r In Sheets("Sheet1").Range("A1").CurrentRegion.Rows
        x = WorksheetFunction.CountA(r)
        ReDim Preserve v(1 To 4, 1 To n + x / 4 + 1)
        m = 0
        For i = 1 To x
            m = m + 1
            If m = 1 Then n = n + 1
            v(m, n) = r.Cells(i).Value
            If m = 4 Then m = 0
        Next
    Next

    Sheets("Sheet2").UsedRange.ClearContents
    Sheets("Sheet2").Range("A1").Resize(n, 4).Value = WorksheetFunction.Transpose(v)

 End Sub

(マナ) 2014/07/29(火) 22:39


試してみましたが空白行が入ります、空白行無しで行いたいのですが、又、このシートに他のデータが有るのでこのシートに挿入したいのですが宜しくお願いします。

(バドファン) 2014/07/30(水) 18:27


他のデータは、どの位置にあるのですか

(マナ) 2014/07/30(水) 19:42


もう一つ質問です。

 >とりあえず、別シートに書き出しています。 

 「とりあえず」確認用に、別シートに書き出していますので、今は気にしていません。
 それより、空白行の問題が気になります。こちらで再現できません。
 どのようなデータのとき、どんな感じで空白行が入りりますか。

(マナ) 2014/07/30(水) 20:28


空白行がわからないままですが同一シート用に修正

 Sub test3()
    Dim myRng As Range
    Dim r As Range
    Dim v() As String
    Dim x As Long
    Dim m As Long, n As Long
    Dim i As Long

    Set myRng = Range("A1").CurrentRegion

    For Each r In myRng.Rows
        x = WorksheetFunction.CountA(r)
        m = 0
        For i = 1 To x
            m = m + 1
            If m = 1 Then
                n = n + 1
                ReDim Preserve v(1 To 4, 1 To n)
            End If
            v(m, n) = r.Cells(i).Value
            If m = 4 Then m = 0
        Next
    Next

    With myRng
        .ClearContents
        .Resize(n - .Rows.Count, 4).Offset(.Rows.Count).Insert Shift:=xlDown
        .Range("A1").Resize(n, 4).Value = WorksheetFunction.Transpose(v)
    End With

 End Sub
 (今日も眠くて頭がまわらないので、ここまでにします)

(マナ) 2014/07/30(水) 20:55


 Sub test()
    Dim a, i As Long, ii As Long, x As Object
    With Cells(1).CurrentRegion
        a = .Value
        If UBound(a, 2) < 5 Then Exit Sub
        ReDim Preserve a(1 To UBound(a, 1), 1 To Application.Floor(UBound(a, 2) + 4, 5))
        With CreateObject("System.Collections.ArrayList")
            For i = 1 To UBound(a, 1)
                For ii = 1 To UBound(a, 2) Step 5
                    .Add Application.Index(a, i, Evaluate("transpose(row(" & ii & ":" & ii + 4 & "))"))
                Next
            Next
            Set x = .Clone
        End With
        .Offset(.Rows.Count + 2).Resize(x.Count, 5).Value = Application.Index(x.ToArray, 0, 0)
    End With
End Sub
(seiya) 2014/07/30(水) 21:37

お世話になります、マナさんtest3で試したらOKでした、実際のフォームは文字列がH列から始まり同じ行の左側A〜Gまで他の文字データが入ってます。(H列を先頭に折り返しかったのですが)

test2の時は文字が4列以内の時下に3行空白行が入って、その他4列以上の物も1行空白行が入ってました。

seiyaさん文字が4列以内時 2行空白行が入り 5列以上時は1行空白行が入ります。

(バドファン) 2014/07/31(木) 17:17


 話がよく見えてないけど...

 Sub test()
    Dim a, i As Long, ii As Long, x As Object
    With Cells(1).CurrentRegion
        a = .Value: .ClearContents
        If UBound(a, 2) < 5 Then Exit Sub
        ReDim Preserve a(1 To UBound(a, 1), 1 To Application.Floor(UBound(a, 2) + 3, 4))
        With CreateObject("System.Collections.ArrayList")
            For i = 1 To UBound(a, 1)
                For ii = 1 To UBound(a, 2) Step 4
                    .Add Application.Index(a, i, Evaluate("transpose(row(" & ii & ":" & ii + 3 & "))"))
                    .Add [if(row(a1:d1),if((a1:d1="")+(a1:d1<>""),""))]
                Next
            Next
            Set x = .Clone
        End With
        .Resize(x.Count - 1, 4).Value = Application.Index(x.ToArray, 0, 0)
    End With
End Sub
(seiya) 2014/07/31(木) 18:09

お世話になります
seiyaさん 話がよく見えてないけど...
 Sub test()をやってみましたが、さらに空白行入りました。
最終的には データには空白行不要で

「任意の行列に文字が有ります、印刷の関係で4列までで、5から8列の範囲内に右端が有れば1行下に空白行を1行挿入して1〜4列の下に5〜8列の文字をコピー、9〜12列の間ならさらに又1行空白行を挿入してその行に9〜12列をコピー、それ以上なら又下にコピーとなります。

 (5〜8の間なら空白行1行挿入、9〜12列の間なら又1行挿入(計2行)、13〜16行の間なら又1行空白行挿入(計3行)−−−− 」
分かりずらくてすいません。
(バドファン) 2014/07/31(木) 19:51

 一行目のA1〜M1まで13列のデータが有ったとして

 A1〜D1はそのままで
 2行目に空白一行挿入
 A3〜D3 にE1〜H1のデータ
 さらに空白行を追加
 A5〜E5 にI1〜L1のデータ
 さらに空白行を追加
 A7にM1のデータ

 ということではないのですか?
(seiya) 2014/07/31(木) 20:18

仮にA1からK1にデータが有った時
A1からD1はそのままで直ぐ下の
2行目に空白一行挿入
 A2〜D2 にE1〜H1のデータをコピー
 さらに空白行を追加し
 A3〜D3にI1〜K1のデータをコピーするとゆうことです。

印字範囲の関係ではみ出た部分をAからD列の範囲に収めたいのです。

(バドファン) 2014/07/31(木) 20:38


 こういうことかな?

 Sub test()
    Dim rng As Range, i As Long, n As Long
    Set rng = Cells(1).CurrentRegion.Rows(1)
    If rng.Columns.Count < 5 Then Exit Sub
    n = 1
    For i = 5 To rng.Columns.Count Step 4
        n = n + 1
        Rows(n).Insert
        rng.Cells(i).Resize(, 4).Cut Rows(n)
    Next
End Sub
(seiya) 2014/07/31(木) 20:59

>同じ行の左側A〜Gまで他の文字データが入ってます。
>(H列を先頭に折り返しかったのですが)

 対応してみました。こういうことですか。

 Sub test4()
    Dim myRng As Range
    Dim r As Range
    Dim v() As String
    Dim x As Long
    Dim m As Long, n As Long
    Dim i As Long

    Set myRng = Range("A1").CurrentRegion

    For Each r In myRng.Rows
        x = WorksheetFunction.CountA(r)
        n = n + 1
        ReDim Preserve v(1 To 11, 1 To n)
        For i = 1 To 8
            v(i, n) = r.Cells(i).Value
        Next
        m = 1
        For i = 9 To x
            m = m + 1
            If m = 1 Then
                n = n + 1
                ReDim Preserve v(1 To 11, 1 To n)
            End If
            v(m + 7, n) = r.Cells(i).Value
            If m = 4 Then m = 0
        Next
    Next

    With myRng
        .ClearContents
        .Resize(n - .Rows.Count, 11).Offset(.Rows.Count).Insert Shift:=xlDown
    End With
    Range("A1").Resize(n, 11).Value = WorksheetFunction.Transpose(v)

 End Sub

(マナ) 2014/07/31(木) 21:32


seiyaさん
1行の下に空白行3行入って後は変化無いです。

マナさんばっちりです。出来たらところどころに注釈を入れてもらえませんか、会社でこれは絶対に無理と友人が言ってましたが、ばっちりです。
(バドファン) 2014/07/31(木) 22:06


 >seiyaさん 
 >1行の下に空白行3行入って後は変化無いです。 

 こっちではちゃんと動いているのを確認しているし、マナさんのを走らせるとエラーになる。

 何かが違うんだろうね。
(seiya) 2014/07/31(木) 22:16

行列をはっきり指定して疑問点を提示しなかったのでどこかが違うんでしょうね、以後是正します。
ありがとうございました。 

マナさん注釈はいつでもいいですから、明日から日曜日までパソコンに触れませんので返信遅れます。
(バドファン) 2014/07/31(木) 22:25


説明が苦手なので、これ以上は勘弁してください。
  
L列(12列)以降、4列毎に折り返すと、
こんな感じですよね。
  
 ABCDEFGHIJKLMNOP
1■■■■■■■□□□□□□□□□
2■■■■■■■□□□□□□□□
3■■■■■■■□□□
4■■■■■■■□□□□□□
  
  ↓
  
 ABCDEFGHIJK
1■■■■■■■□□□□
2−−−−−−−□□□□
3−−−−−−−□−−−
4■■■■■■■□□□□
−−−−−−−□□□□−
5■■■■■■■□□□−
6■■■■■■■□□□□
7−−−−−−−□□−−
  
なので、最終的に並べ替えた後の状態は
縦は何行になるかわかりませんが
横は、11列(A〜K列)なので、
 11×nの入れ物(配列v)を用意して
 その中に、データを並べ替え(折り返し)ながら取り込んでます。
 そして最後に、元データを消去したあと、
 並べ替えた配列内のデータを貼り付けています。

 11列までは、折り返しがないので、無条件に取り込んでいます。
 For i = 1 To 11
    v(i, n) = r.Cells(i).Value
 Next

 で、12列目以降で折り返しが発生する場合は、
 こんな感じで、都度、配列サイズを増やしています。
 n = n + 1
 ReDim Preserve v(1 To 11, 1 To n)

 いつ折り返すかは、判定用の変数mを用意し
 取り込み回数をカウントし、4回取り込んだらリセットして、
 m = m + 1
 If m = 4 Then m = 0

 つまり、m = 0かどうかで判断しています。(If m = 0 Then)
 折り返した後の開始は、8列目なので、取り込み位置は m + 8とします。
 v(m + 8, n) = r.Cells(i).Value

 取り込みは行毎に行い、(For Each r In myRng.Rows〜Next)
 すべての行について取り込みが終わったら
 並べ替えたデータを最後に貼り付けです。

と説明書いていたら、わかりにくい部分があったので、少し修正しました。

 Sub test5()
    Dim myRng As Range
    Dim r As Range
    Dim v() As String
    Dim x As Long
    Dim m As Long, n As Long
    Dim i As Long

    Set myRng = Range("A1").CurrentRegion

    For Each r In myRng.Rows
        x = WorksheetFunction.CountA(r)
        n = n + 1
        ReDim Preserve v(1 To 11, 1 To n)

        For i = 1 To 11
            v(i, n) = r.Cells(i).Value
        Next

        m = 0     
        For i = 12 To x
            If m = 0 Then
                n = n + 1
                ReDim Preserve v(1 To 11, 1 To n)
            End If
            v(m + 8, n) = r.Cells(i).Value
            m = m + 1
            If m = 4 Then m = 0
        Next
    Next

    With myRng
        .ClearContents
        .Resize(n - .Rows.Count, 11).Offset(.Rows.Count).Insert Shift:=xlDown
    End With
    Range("A1").Resize(n, 11).Value = WorksheetFunction.Transpose(v)

 End Sub

(マナ) 2014/08/02(土) 19:30


マナさん お世話になります。
test5やってみました。バッチリです。説明をみながらなんとなくですが、ゆっくり応用していきたいと思います。本当にありがとうございました。又、次回目に留まったら宜しくお願いします。
(バドファン) 2014/08/03(日) 19:10

コメント返信:

[ 一覧(最新更新順) ]


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