Excel 複数行のデータを1行にするVBA

質問

Sheet1にA列～T列まで不規則にデータが存在する
行が500行有ります

(1)　これを1行にする（VBA）
（Sheet2に表示）
(2)　1列にして（行列入れ替え）
(3)　空白以外を表示する（オートフィルタ）

を試みましましたが
上手くいきません
特に(1)のマクロが途中で止まります
おそらくデータが多すぎるのだと思います
何とか良い方法が無いかと色々試しますが・・・
その道のプロフェッショナルな方
手を差しのべて頂けないでしょうか？

このような感じでやっています

Dim ss As Worksheet
Dim ds As Worksheet
Dim r As Integer
Set ss = Sheets("sheet1")
Set ds = Sheets("sheet2")
ds.Cells.Clear
For r = 1 To 1000
ds.Cells(((r - 1) \ 20) + 1, ((r - 1) Mod 20) * 20 + 1) = ss.Cells(r, 1)
ds.Cells(((r - 1) \ 20) + 1, ((r - 1) Mod 20) * 20 + 2) = ss.Cells(r, 2)
ds.Cells(((r - 1) \ 20) + 1, ((r - 1) Mod 20) * 20 + 3) = ss.Cells(r, 3)
ds.Cells(((r - 1) \ 20) + 1, ((r - 1) Mod 20) * 20 + 4) = ss.Cells(r, 4)
ds.Cells(((r - 1) \ 20) + 1, ((r - 1) Mod 20) * 20 + 5) = ss.Cells(r, 5)
ds.Cells(((r - 1) \ 20) + 1, ((r - 1) Mod 20) * 20 + 6) = ss.Cells(r, 6)
ds.Cells(((r - 1) \ 20) + 1, ((r - 1) Mod 20) * 20 + 7) = ss.Cells(r, 7)
ds.Cells(((r - 1) \ 20) + 1, ((r - 1) Mod 20) * 20 + 8) = ss.Cells(r, 8)
ds.Cells(((r - 1) \ 20) + 1, ((r - 1) Mod 20) * 20 + 9) = ss.Cells(r, 9)
ds.Cells(((r - 1) \ 20) + 1, ((r - 1) Mod 20) * 20 + 10) = ss.Cells(r, 10)
ds.Cells(((r - 1) \ 20) + 1, ((r - 1) Mod 20) * 20 + 11) = ss.Cells(r, 11)
ds.Cells(((r - 1) \ 20) + 1, ((r - 1) Mod 20) * 20 + 12) = ss.Cells(r, 12)
ds.Cells(((r - 1) \ 20) + 1, ((r - 1) Mod 20) * 20 + 13) = ss.Cells(r, 13)
ds.Cells(((r - 1) \ 20) + 1, ((r - 1) Mod 20) * 20 + 14) = ss.Cells(r, 14)
ds.Cells(((r - 1) \ 20) + 1, ((r - 1) Mod 20) * 20 + 15) = ss.Cells(r, 15)
ds.Cells(((r - 1) \ 20) + 1, ((r - 1) Mod 20) * 20 + 16) = ss.Cells(r, 16)
ds.Cells(((r - 1) \ 20) + 1, ((r - 1) Mod 20) * 20 + 17) = ss.Cells(r, 17)
ds.Cells(((r - 1) \ 20) + 1, ((r - 1) Mod 20) * 20 + 18) = ss.Cells(r, 18)
ds.Cells(((r - 1) \ 20) + 1, ((r - 1) Mod 20) * 20 + 19) = ss.Cells(r, 19)
ds.Cells(((r - 1) \ 20) + 1, ((r - 1) Mod 20) * 20 + 20) = ss.Cells(r, 20)
Next

回答No.2

mt2008 · ベストアンサー

エラーになるのはANo.1の方も指摘されているように列の最大数に引っかかっているからでしょう。

最終的に1列にまとめたいのなら、素直にループを2つ回して処理をした方がシンプルですよ。

Sub sample()
　　Dim ss As Worksheet
　　Dim ds As Worksheet
　　Dim nRow, nCol, nCount
　　Set ss = Sheets("sheet1")
　　Set ds = Sheets("sheet2")
　　ds.Cells.Clear

　　For nRow = 1 To 1000
　　　　For nCol = 1 To 20
　　　　　　If ss.Cells(nRow, nCol).Value <> "" Then
　　　　　　　　nCount = nCount + 1
　　　　　　　　ds.Cells(nCount, 1) = ss.Cells(nRow, nCol)
　　　　　　End If
　　　　Next nCol
　　Next nRow
End Sub

お礼

なるほど
さすが素晴らしいです
直接　1行に
思いつきませんでした
助かりました
ありがとうございます

回答No.1

utun01

こういうことでしょうか？
とりあえず一行に纏める所だけ作ってみました。

Public Sub cptest()
Dim sht1 As Worksheet
Dim sht2 As Worksheet
Dim targetRng As Range
Dim rng As Range
Dim colcount As Long
Set sht1 = ThisWorkbook.Worksheets("Sheet1")
Set sht2 = ThisWorkbook.Worksheets("Sheet2")
Set targetRng = sht2.Range("A1")
colcount = 0
For Each rng In sht1.UsedRange
targetRng.Offset(0, colcount).Value = rng.Value
colcount = colcount + 1
Next
End Sub

ちなみにですが、Excel2003までは列が255までしか無いので500列入力することはできません。
また、Excel2007以降でも16384列が最大なので、それ以上の要素数がある場合できません。

お礼

ありがとうございます
Excel　2003です
原因が分かり
よかったです
助かりました