dポイントプレゼントキャンペーン実施中!

現在エクセル上で以下の様なデータ処理を行っています。
c05
p2
v1
v5
空白セル
b07
b11
空白セル
b07
空白セル
a06
a07
a09
i1
i6
j8
p9
s1
というデータを
c05p2v1v5
p2v1v5
v1v5
v5
空白セル
b07b11
b11
空白セル
b07
空白セル
a06a07a09i1i6j8p9  s1
a07a09i1i6j8p9s1
a09i1i6j8p9s1
i1i6j8p9s1
i6j8p9s1
j8p9s1
p9s1
s1
とこのように転置を行いたいと考えています。
数千行ならばマクロの記録などを利用しやる事も出来るのですが、データ量が50万行と非常に多いのでこれらの作業を一括で行いたいと思い質問させて頂きました。
このような作業をするにはVBAでやるのが早いと思うのですが、どのような処理をさせたらいいのでしょうか?
またなにか参考になるサイト・参考書等がありましたら教えてください。

A 回答 (6件)

>転置


Transposeといウと思うが、エクセルでは特別な意味がある。適当でない。「並べ替え組み合わせ」程度の表現が良いかと。
>長々と質問に例を挙げていて、それなりに理解の助けになるが、どういう仕組みかを考え、質問に文章でも表現するクセをつけないと。
ーー
空白まで行数をnとして、最上行から数えて、n、n-1,n-2、・・・2,1個取るが、x個を取る行数を1つずつ下げている。
こういうことでよいのかな。
ーー
例データ A列A1:A18
c05
p2
v1
v5

b07
b11

b07

a06
a07
a09
i1
i6
j8
p9
s1
ーー
標準モジュールに
Sub test01()
d = Range("a65536").End(xlUp).Row
MsgBox d
s = 1 'スタートセル
k = 1 '結果のスタート行
m = 8 '結果のスタート列
Range("A1").Select
Range("a1:A100").Select '範囲を100行と仮定
'---以下繰り返し
Do While s < d
n = Selection.Find(What:="").Row 'A列で空白行を見つける
l = n - s '空白から空白までのセル数
MsgBox n
For i = 0 To l - 1
For j = s + i To n
Cells(k, m) = Cells(j, "A")
m = m + 1 '1列右へ
Next j
m = 8 '結果のスタート列
k = k + 1 '一行下へ
Next i
'--検索範囲の取り直し
Range(Cells(n + 1, "A"), Cells(100, "A")).Select
s = n + 1 'スタートセルを設定し直し
Loop
End Sub
ーー
結果(この場合H列から右に)
c05p2v1v5
p2v1v5
v1v5
v5
b07b11
b11
b07
a06a07a09i1i6j8p9s1
a07a09i1i6j8p9s1
a09i1i6j8p9s1
i1i6j8p9s1
i6j8p9s1
j8p9s1
p9s1
s1
少しの修正で済むはずだが、これを本番用に作り直せるかな。
なるべく範囲のスタートとエンドを小刻みに分割して、実行することをお勧めする。
こういう2重ループのロジックのプログラムは相当慣れないと混乱すると思うが、行数が少なくはなる。
なおMsgboxは確認用なので、本番ではその行を削除のこと。
    • good
    • 0

#04です。


#04のマクロよりも#02さんの回答の方がアルゴリズムは圧倒的に優れています。脱帽です。

そこで#04を書き換えました。別シートに書き込むところは先の回答と一緒ですので3、4行目を修正してください

Sub Macro2()
Dim idx, cnt As Long
Const sht As String = "Sheet2"
Const clm As String = "A"
Application.ScreenUpdating = False
With ActiveSheet
  For idx = .Cells(.Rows.Count, clm).End(xlUp).Row To 1 Step -1
  If .Cells(idx, clm).Value = "" Then
    cnt = 0
  Else
    Sheets(sht).Cells(idx, 1).Value = .Cells(idx, clm)
    If cnt > 0 Then
      Sheets(sht).Cells(idx + 1, clm).Resize(1, cnt).Copy Sheets(sht).Cells(idx, 2)
    End If
    cnt = cnt + 1
  End If
  Next idx
End With
Application.ScreenUpdating = True
End Sub
    • good
    • 0

>どのような処理をさせたらいいのでしょうか?


プログラムの経験はおありですか? もしあまり経験がないなら、アルゴリズムを考えるのがかなりつらいと思いましたので、とりあえずサンプルを書きました。

以下のマクロをALT+F11でVBE画面を開き、左上のVBA Projectでシート名を右クリックし「挿入」→「標準モジュール」で表示される画面に貼り付けて下さい。マクロの実行は元データが入力されているシート画面に戻ってALT+F8でマクロ一覧を開き、マクロ名を選択して「実行」ボタンです。
(2007なら開発リボンは表示しておいてくださいね)

並べ替え結果は別シートに書き込むようにしました。マクロの5、6行目は実際の列名とシート名に変更してください

Sub Macro1()
Dim idx, frm, cnt As Long
Dim ptr2, idx2 As Long
Const clm As String = "A" '元データが書かれている列名
Const sht As String = "Sheet2" '並び替え結果を書き込むシート名
 Application.ScreenUpdating = False
 frm = 0
 cnt = 0
 ptr2 = Sheets(sht).Cells(Sheets(sht).Rows.Count, "A").End(xlUp).Row + 1
 With ActiveSheet
  For idx = 1 To .Cells(.Rows.Count, clm).End(xlUp).Row + 1
   If .Cells(idx, clm) <> "" Then
    cnt = cnt + 1
    If frm = 0 Then
     frm = idx
    End If
   Else
    If cnt > 0 Then
     .Cells(frm, clm).Resize(cnt).Copy Sheets(sht).Cells(ptr2, "A")
     For idx2 = 1 To cnt - 1
      Sheets(sht).Cells(ptr2, "A").Offset(idx2, 0).Resize(cnt - idx2).Copy _
       Destination:=Sheets(sht).Cells(ptr2, "A").Offset(0, idx2)
     Next idx2
     ptr2 = ptr2 + cnt + 1
     frm = 0
     cnt = 0
    End If
   End If
  Next idx
 End With
 Application.ScreenUpdating = True
End Sub

なお「マクロが分からないから解説、修正してください」はナシです。
それはご自身がマクロを勉強して行ってください。エラーが発生した場合はその限りではありません。
    • good
    • 0

ANo.2です。


wがintegerを超える可能性があるので、
Dim w As Integer

Dim w As Long
に変更してください。
    • good
    • 0

c05 p2 v1 v5


というのが、
A1=c05,B1=p2,C1=v1,D1=v5
なのか、
A1=c05 p2 v1 v5
なのかわからないので、両方考えました。
考え方としては、最後の行から処理した方が楽だという事です。
-----------------------
'cell毎にデータを配置する場合
Sub test1()
Dim ws As Worksheet
Dim row As Long
Dim w As Integer

Set ws = Worksheets("sheet1") '目的のシート
For row = ws.Cells(ws.Rows.Count, 1).End(xlUp).row To 1 Step -1
If ws.Cells(row, 1) = "" Then
w = 0
Else
w = w + 1
If w > 1 Then
ws.Range(ws.Cells(row + 1, 1), ws.Cells(row + 1, w - 1)).Copy Destination:=ws.Cells(row, 2)
End If
End If
Next
End Sub
-----------------------
'A列にデータを配置する場合
Sub test2()
Dim ws As Worksheet
Dim row As Long
Dim w As Integer

Set ws = Worksheets("sheet1") '目的のシート
For row = ws.Cells(ws.Rows.Count, 1).End(xlUp).row To 1 Step -1
If ws.Cells(row, 1) = "" Then
w = 0
Else
w = w + 1
If w > 1 Then
ws.Cells(row, 1) = ws.Cells(row, 1) & " " & ws.Cells(row + 1, 1)
End If
End If
Next
End Sub

p.s.
excel2000で試しました・・・
    • good
    • 0

ヒント



セルのコピー1
Cells(1,2)=Cells(2,1)でA2セルの内容をB1にコピー。

セルのコピー2
Cells(1,2)=Cells(2,1) & " " & Cells(3,1)でA2セル、スペース、A3セルとしてB1にコピー。

空白セルの判断
If Cells(2,1)="" Then
~~
End If
A2セルが空白なら~~を実行します。

繰り返し
For i=1 To 50000
~~~
Next i
iを1,2,3,4・・・と変化させながら~~~を実行する。
途中で終わらせたいときは、Exit Forとする。

以上を組み合わせれば、作れます。

でも、よく見たら50万行のデータはエクセルの1シートでは処理できません。
複数シートに分かれていて全部で50万行ですか?

この回答への補足

回答ありがとう御座いました。
50万行のデータですが、エクセル2007を利用しておりますので、1シートで作業しています。

補足日時:2007/12/12 18:14
    • good
    • 0

お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!