[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『空白行挿入とコピー』(バドファン)
任意の行列に文字が有ります、印刷の関係で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
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
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
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
対応してみました。こういうことですか。
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
マナさんばっちりです。出来たらところどころに注釈を入れてもらえませんか、会社でこれは絶対に無理と友人が言ってましたが、ばっちりです。
(バドファン) 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
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.