行列を入れ替えて貼り付けの自動化

質問

Ａ列に数値データ、Ｂ列に文字データが入力されています。
これをコピーして形式を選択して貼り付けで行列を入れ替えて、1行目のＡ～Ｊ列に数値、Ｋ～Ｔ列に文字と10個単位でどんどん移動をかけます。
データ数は3000件以上ありできれば上記作業を自動化したいのですが・・・。
みなさんどうかお願い致します。

回答No.11

mousengoke · ベストアンサー

すみません。
前のは10個目に空欄があっても一行空きませんでした。

Option Explicit

Sub irekae()
　　Const halfretsu = 10

　　Dim mototop As Integer
　　Dim atotop As Integer
　　Dim gyou As Integer
　　Dim thislinec As Integer

　　mototop = 1
　　atotop = 1
　　gyou = Range("A10000").End(xlUp).Row

　　Do While mototop <= gyou
　　　　thislinec = ido(mototop, atotop, halfretsu)

　　　　If thislinec < 0 Then
　　　　　　mototop = mototop + halfretsu
　　　　　　atotop = atotop + 1
　　　　Else
　　　　　　mototop = mototop + thislinec
　　　　　　atotop = atotop + 2
　　　　End If
　　Loop
　　Columns("A:C").Select
　　Selection.Delete Shift:=xlToLeft
End Sub

Private Function ido(mototop, atotop, halfretsu)
　　Dim tempnum As Integer
　　Dim stopnum As Integer
　　Dim tempchar As String

　　Const yobiake = 3

　　Dim i As Integer

　　stopnum = -1

　　For i = 1 To halfretsu
　　　　If Cells(mototop + i - 1, 2).Value = "" Then
　　　　　　stopnum = i
　　　　　　Exit For
　　　　End If

　　　　tempnum = Cells(mototop + i - 1, 1).Value
　　　　Cells(mototop + i - 1, 1).Value = ""
　　　　Cells(atotop, i + yobiake).Value = tempnum
　　　　tempchar = Cells(mototop + i - 1, 2).Value
　　　　Cells(mototop + i - 1, 2).Value = ""
　　　　Cells(atotop, i + halfretsu + yobiake).Value = tempchar
　　Next
　　ido = stopnum
End Function

お礼

感動です。
正直無理なんだと思ってました。
ダミーで150件試しましたがきれいに並び変わりました。
本当にありがとうございました。

回答No.10

mousengoke

すいませんなんか勘違いしていたようで
もし途中で空行があったらその行へのコピーをやめて一行あけてからコピーを再開する。
でいいんですね?

Option Explicit

Sub irekae()
　　Const halfretsu = 10

　　Dim mototop As Integer
　　Dim atotop As Integer
　　Dim gyou As Integer
　　Dim thislinec As Integer

　　mototop = 1
　　atotop = 1
　　gyou = Range("A10000").End(xlUp).Row

　　Do While mototop <= gyou
　　　　thislinec = ido(mototop, atotop, halfretsu)
　　　　mototop = mototop + thislinec
　　　　If thislinec >= halfretsu Then
　　　　　　atotop = atotop + 1
　　　　Else
　　　　　　atotop = atotop + 2
　　　　End If
　　Loop
　　Columns("A:C").Select
　　Selection.Delete Shift:=xlToLeft
End Sub

Private Function ido(mototop, atotop, halfretsu)
　　Dim tempnum As Integer
　　Dim tempchar As String

　　Const yobiake = 3

　　Dim i As Integer

　　For i = 1 To halfretsu
　　　　If Cells(mototop + i - 1, 2).Value = "" Then
　　　　　　Exit For
　　　　End If

　　　　tempnum = Cells(mototop + i - 1, 1).Value
　　　　Cells(mototop + i - 1, 1).Value = ""
　　　　Cells(atotop, i + yobiake).Value = tempnum
　　　　tempchar = Cells(mototop + i - 1, 2).Value
　　　　Cells(mototop + i - 1, 2).Value = ""
　　　　Cells(atotop, i + halfretsu + yobiake).Value = tempchar
　　Next
　　ido = i
End Function

回答No.9

mousengoke

No.2です。
前のは10行ずつ書入りした後の次のA列のトップ(例えばA41)に空欄があったらストップするように作ってあったのでたまたまそこに空欄があったら止まってしまうものでした。
とりあえず、元のデータが行数が1万行未満という想定で作り変えてみました。

Option Explicit

Sub irekae()
　　Const halfretsu = 10

　　Dim mototop As Integer
　　Dim atotop As Integer
　　Dim gyou As Integer
　　Dim gyouA As Integer
　　Dim gyouB As Integer

　　mototop = 1
　　atotop = 1
　　gyouA = Range("A10000").End(xlUp).Row
　　gyouB = Range("B10000").End(xlUp).Row
　　If gyouA >= gyouB Then
　　　　gyou = gyouA
　　Else
　　　　gyou = gyouB
　　End If

　　Do While mototop <= gyou
　　　　Call ido(mototop, atotop, halfretsu)
　　　　mototop = mototop + halfretsu
　　　　atotop = atotop + 2
　　Loop

End Sub

Private Sub ido(mototop, atotop, halfretsu)
　　Dim tempnum As Integer
　　Dim tempchar As String

　　Dim i As Integer

　　For i = 1 To halfretsu
　　　　If Cells(mototop + i - 1, 1).Value <> "" Then
　　　　　　tempnum = Cells(mototop + i - 1, 1).Value
　　　　　　Cells(mototop + i - 1, 1).Value = ""
　　　　　　Cells(atotop, i).Value = tempnum
　　　　End If

　　　　tempchar = Cells(mototop + i - 1, 2).Value
　　　　Cells(mototop + i - 1, 2).Value = ""
　　　　Cells(atotop, i + halfretsu).Value = tempchar
　　Next
End Sub

お礼

ありがとうございます。
試してみたところなぜか一行おきに改行が入ってしまいますです・・・・

回答No.8

Sam_A

No,#4-5です。
補足要求しますが、元軸計算はA列（数字）の方でよろしいのでしょうか？

例えばB列（文字）に空行（NULL）がある場合の扱いは同じくご質問にあるように空行扱いでOKなのか、
又は、あくまでA列が空行だった場合だけに空行処理をするのか、その辺が曖昧な感じがします。

＊：A列が空行なら必ずB列も空行なのでしょうか？
＊：移し替えが１０未満でも途中に空行があったら強制的に行をあけるのでしょうか？

補足

A列が空行なら必ずB列も空行です。
移し替えが10未満でも途中空行があったら強制的に行を空けます。
1～50のデータで25行目と31行目が空行であれば
1 2 3 4 5 6 7 8 910
11121314151617181920
21222324

2627282930

32333435363738394041
424344454647484950

と並んで欲しいのです

回答No.7

imogasi

＃６のものです。＃６の補足にお書きになっている要求は
、やって見たところ＃３の回答のままで叶えられると思います。
Ａ列、Ｂ列に空白のセルが散在・混在しておれば、そのまま所定の所へ空白セルを移します。
やってみてくださって、不都合な点があればお知らせ下さい。

補足

私の説明不足ですみません、補足致します。
所定のセル（行）が空白である場合そのまま移すのではなく空行を一つ作って欲しいのです。2行以上の空白（行）があればマクロを止めて欲しいのです。A列1～31、B列あ～、の場合で3行目と10行目に空行がある場合

12　　　　　　　　　あい
※3行目がないので空行
456789　　　　　　　うえおかきく
※10行目がないので空行
11121314151617181920けこさしすせそたちつ
21222324252627282930てとなにぬねのはひふ
31　　　　　　　　　　へ

このような説明でわかりますでしょうか・・・

回答No.6

imogasi

#1,#3のものです。
実はデータは3000件ちょうどではなく、その時々で異なります。
なのでこのVBAだと都度件数を把握しなければならず
少し色々盛りこまないように遠慮してました。
簡単です。
d = Range("a1").CurrentRegion.Rows.Count
かまたは
d=Range("A65536").End(xlUp).Row を最初に入れる。
For i = 1 To 300 Step 10 をFor i = 1 To d Step 10
に変更するで解決します。

お礼

imogasiさんは朝早いんですね（＾＾）丁寧にありがとうございます。
試したところ無事うごきました、ありがとうございます。
そこで相談なのですが↑補足のような事もできるものでしょうか？

補足

元データの途中に空行がある場合、並べ替え後データも空行を作ることはできるでしょうか？
１　　　　　　１２３４
２
３　　　　　　５６７
４
　　　→
５
６
７
という感じで１行１０個なくても改行になり、さらに１行空行を入れてまた続きが入る。
なんとかなりますでしょうか・・・

回答No.5

Sam_A

No,#4です。
勘違いしておりました。スミマセンm(__)m
再調整版をUPします。
--------------------------------------------------
Sub Macro2()

Dim myLastLow As Long, i As Long, n As Long
Dim str As String, str2 As String
Dim str_rv As String, str_rv2 As String, str_rv3 As String, str_rv6 As String

n = 1
n2 = 1

myLastLow = Range("A65536").End(xlUp).Row
Cells(1, 1).Select

MsgBox "myLastLow = " & myLastLow

For i = 1 To myLastLow Step 10

str_rv = i
str_rv2 = i + 9
str_rv3 = n
str_rv6 = n

str = "A" + str_rv + ":A" + str_rv2
Range(str).Select
Application.CutCopyMode = False
Selection.Copy
Range("C" + str_rv3).Select
Selection.PasteSpecial Paste:=xlAll, Operation:=xlNone, SkipBlanks:=False _
, Transpose:=True

str2 = "B" + str_rv + ":B" + str_rv2
Range(str2).Select
Application.CutCopyMode = False
Selection.Copy
Range("M" + str_rv6).Select
Selection.PasteSpecial Paste:=xlAll, Operation:=xlNone, SkipBlanks:=False _
, Transpose:=True
n = n + 1
Next i

MsgBox "A&B列を削除します。"
Columns("A:B").Select
Selection.Delete Shift:=xlToLeft
Range("A1").Select

End Sub

お礼

そこでちょっと相談なのですが、下の方にも着込みしたのですが、元データの途中に空行がある場合、並べ替え後データも空行を作ることはできるでしょうか？

１　　　　　　１２３４
２
３　　　　　　５６７
４
　　　→
５
６
７

という感じで１行１０個なくても改行になり、さらに１行空行を入れてまた続きが入る。

なんとかなりますでしょうか・・・

補足

※お礼文の100文字制限でお礼が切れてしまいました、すみません。

回答ありがとうございます！うまく動いたのですが↓のような事はできるものでしょうか？

回答No.4

Sam_A

お望みの処理はこんな感じでしょうか？
汎用的な可変タイプのマクロを組んでみました。
バックアップを作成してから下記のマクロを試してみて下さい。
--------------------------------------------------
Sub Macro()

Dim myLastLow As Long, i As Long, n As Long
Dim str As String, str2 As String
Dim str_rv As String, str_rv2 As String, str_rv3 As String, str_rv6 As String

n = 1
n2 = 1

myLastLow = Range("A65536").End(xlUp).Row
Cells(1, 1).Select
MsgBox "myLastLow = " & myLastLow

For i = 1 To myLastLow Step 10

str_rv = i
str_rv2 = i + 9
str_rv3 = n
str_rv6 = n + 1

str = "A" + str_rv + ":A" + str_rv2
Range(str).Select
Application.CutCopyMode = False
Selection.Copy
Range("C" + str_rv3).Select
Selection.PasteSpecial Paste:=xlAll, Operation:=xlNone, SkipBlanks:=False _
, Transpose:=True

str2 = "B" + str_rv + ":B" + str_rv2
Range(str2).Select
Application.CutCopyMode = False
Selection.Copy
Range("C" + str_rv6).Select
Selection.PasteSpecial Paste:=xlAll, Operation:=xlNone, SkipBlanks:=False _
, Transpose:=True
n = n + 2
Next i

MsgBox "A&B列を削除します。"
Columns("A:B").Select
Selection.Delete Shift:=xlToLeft
Range("A1").Select

End Sub

回答No.3

imogasi

テストデータとして
Ａ１に１、Ａ２に２を入れ、Ａ１：Ａ２を範囲指定して
＋ハンドルを出し引っ張る。１－数百の連続数を入力する。
Ｂ１に５０１、Ｂ２に５０２を入れ、Ｂ１：Ｂ２を範囲指定して＋ハンドルを出し下へ引っ張る。５０１－連続数を
セルにセットする。
Sub test02()
j = 1
'For i = 1 To 3000 Step 10
For i = 1 To 300 Step 10
Worksheets("Sheet1").Select
Worksheets("Sheet1").Range(Cells(i, "A"), Cells(i + 9, "A")).Copy
Worksheets("Sheet2").Select
Cells(j, "A").Select
Selection.PasteSpecial Paste:=xlAll, Transpose:=True
'-------
Worksheets("Sheet1").Select
Worksheets("Sheet1").Range(Cells(i, "B"), Cells(i + 9, "B")).Copy
Worksheets("Sheet2").Select
Cells(j, "K").Select
Selection.PasteSpecial Paste:=xlAll, Transpose:=True
j = j + 1
Next i
End Sub
を標準モジュール画面にコピーし、実行する。
結果はＳｈｅｅｔ２にＡ１：ＴＸＸＸに
１、２、３・・１０，５０１，５０２、・・５１０
１１，１２、１３・・５１１、５１２，５１３、・・５２０
２１，２２，２３、・・５２１，５２２、・・５３０
・・・
となります。
「標準モジュール画面にコピーし、実行する」方法がわからなければ補足します。
’の付いた行は３０００行を処理するときのためです。
’を省けば３０００行用になります。その時は
For i = 1 To 300 Step 10の行を抹消します。

お礼

回答ありがとうございます。
実はデータは3000件ちょうどではなく、その時々で異なります。
なのでこのVBAだと都度件数を把握しなければならず少々不便な感じがしました。（勝手いってすみません）

回答No.2

mousengoke

多分こういうのはマクロを使わないと無理だと思います。
念のため「形式を選択して貼り付け」は「値」だけを選ぶんですよね?

ツール(T)→マクロ(M)→Visual Basic Editor(V)
または
Alt+F11
で
Visual Basic Editorを起動する。
挿入(I)→標準モジュール(M)
として
右側に出来たウィンドウに

Sub irekae()
　　Const halfretsu = 10

　　Dim mototop As Integer
　　Dim atotop As Integer

　　mototop = 1
　　atotop = 1

　　Do While Cells(mototop, 1).Value <> ""
　　　　Call ido(mototop, atotop, halfretsu)
　　　　mototop = mototop + halfretsu
　　　　atotop = atotop + 1
　　Loop

End Sub

Private Sub ido(mototop, atotop, halfretsu)
　　Dim tempnum As Integer
　　Dim tempchar As String

　　Dim i As Integer

　　For i = 1 To halfretsu
　　　　tempnum = Cells(mototop + i - 1, 1).Value
　　　　Cells(mototop + i - 1, 1).Value = ""
　　　　tempchar = Cells(mototop + i - 1, 2).Value
　　　　Cells(mototop + i - 1, 2).Value = ""

　　　　Cells(atotop, i).Value = tempnum
　　　　Cells(atotop, i + halfretsu).Value = tempchar
　　Next

End Sub

をコピーして貼り付けてください。
その後上書き保存をしてVisual Basic Editorを閉じてください。

ツール(T)→マクロ(M)→マクロ(M)
または
Alt+F8
で呼び出したウィンドウの
irekae
を選んで
実行(R)
をクリックしてください。

回答に対する補足にあるアルゴリズムだと無駄があるので一部を省いて結果として同じになるものになってるはずです。

お礼

お答えありがとうございます
試してみたところ残念ながらコンパイルエラーがでてirekaeが使えませんでした

補足

すみません！使えました！
私が２回貼り付けボタンを押していたようですｍ（＿＿；）ｍ
Visual Basic Editorの使用方法もあり大変わかりやすいです。
そこでちょっと相談なのですが、元データの途中に空行がある場合、並べ替え後データも空行を作ることはできるでしょうか？

１　　　　　　１２３４
２
３　　　　　　５６７
４
　　　→
５
６
７

という感じで１行１０個なくても改行になり、さらに１行空行を入れてまた続きが入る。

なんとかなりますでしょうか・・・

回答No.1

imogasi

作業が良く呑み込み出来ません。
第１回Ａ１：Ａ１０－－－＞別シート（？）Ａ１：Ｊ１
　　　Ｂ１：Ｂ１０－－－＞　　　　　　　Ｋ１：Ｔ１
第２回Ａ１１：Ａ２０（？）－－－＞？？？
　　　Ｂ１１：Ｂ２０（？）－－－＞？？？
第３回？？？？
３０００件とはＳｈｅｅｔ１（例）に約３０００行のデータがあるてことですか。
表にデータがあるのは、Ａ１：Ｂ３０００ですか。

補足

早朝レスありがとうございますm(_ _)m。
一つのシートに3000行です、データがあるのはＡ1：Ｂ3000ですが現在はこれを

１．行の挿入で数行空ける（仮に5行挿入すればデータはＡ6：Ｂ3006にずれます）
２．Ａ6：Ａ15をコピーし、形式を選択して貼り付けでＡ1：Ｊ1へ行列を入れ替えて貼り付け
３．Ｂ6：Ｂ15をコピーし、形式を選択して貼り付けでＫ1：Ｔ1へ行列を入れ替えて貼り付け
４．貼り付けが済んだＡ6：Ｂ15を削除
５．上記１～４で１つのセット、次はＡ16：Ａ25をコピーしてＡ2：Ｊ2へ、Ｂ16：Ｂ25をコピーしてＫ2：Ｔ2へ、コピーが済んだＡ16：Ｂ25は削除・・・と繰り返していく
６．だんだんとコピー元と貼り付け場所が離れていくので時々行削除して作業しやすいようにしなければいけない。見た目としては2列の細長いデータが20列の長方形に変わっていく。

上記のように処理しています