Exelの表を以下のように全行組み替えたいと思いますが、手作業では大変

Exelの表を以下のように全行組み替えたいと思いますが、手作業では大変

Exel の表を以下のように全行組み替えたいと思いますが、手作業では大変です。
そこでマクロを作って作業をさせたいのですが、どのように記述すればよいでしょうか？

No.1 ベストアンサー 回答者： 9der-qder 回答日時： 2010/05/11 13:29

マクロを使わなくても、

元表が列A～列Fまでにあるとすれば
cell(G1)=A1
cell(H1)=A2
cell(I1)=B1
cell(J1)=B2
cell(K1)=C1
cell(L1)=D1
cell(M1)=E1
cell(N1)=E2
cell(O1)=F1
cell(P1)=F2
として、G1:P2（P1ではなくP2です）を選択して下に引っ張る。
G:Pを選択して、コピー「形式を選択して貼り付け」「値」でペースト。
G:Pを「空白以外のセル」でフィルタを掛けて、コピー＆別シートにペーストで出来ます。

この回答へのお礼

同じシート内でなので手順もカンタンでわかりやすい方法でした。
どうもありがとうございます。

お礼日時：2010/05/11 16:46

No.3 回答者： Wendy02 回答日時： 2010/05/11 15:21

'データのある当該シートモジュールか、標準モジュール

Sub ArrangedMatrix()
　　Dim ar() As Variant
　　Dim i As Long, j As Long, k As Long, n As Long
　　Dim rng As Range
　　Dim pstRng As Range
　　'//
　　Set rng = Range("A3", Range("A3").End(xlDown)) 'データ範囲
　　Set pstRng = Range("A20") '貼付け位置
　　'Worksheets("Sheet2").Range("A1") '違うシートの場合
　　'//
　　If Range("A3").End(xlDown).Row = Rows.Count Then
　　　　MsgBox "表が違うかもしれません。", vbExclamation
　　　　Exit Sub
　　ElseIf rng.Parent Is pstRng.Parent Then
　　　　If Not Intersect(rng, pstRng) Is Nothing Then
　　　　MsgBox "貼付け場所が重なっています。", vbExclamation
　　　　　Exit Sub
　　　　End If
　　End If
　　
　　ReDim ar(9, Int(rng.Rows.Count / 2) - 1)
　　For i = 1 To rng.Rows.Count Step 2
　　　　For j = 1 To 12
　　　　　　If rng.Cells(i + n, Int((j - 1) / 2) + 1).Value <> "" Then
　　　　　　　　ar(k, Int(i / 2)) = rng.Cells(i + n, Int((j - 1) / 2) + 1).Value
　　　　　　　　k = k + 1
　　　　　　　　If n = 1 Then n = 0 Else n = n + 1
　　　　　　Else
　　　　　　　　n = 0
　　　　　　End If
　　　　Next
　　　　k = 0
　　Next
　　'項目名
　　pstRng.Resize(, 10).Value = Array("受注NO", "管理NO", "注文品", "顧客名", "受注金額", "取引日", "営業部門", "営業担当", "営業部門", "製造担当")
　　pstRng.Offset(1).Resize(Int(rng.Rows.Count / 2), 10).Value = Application.Transpose(ar)
　　Set rng = Nothing
　　Set pstRng = Nothing
　　Beep
End Sub

この回答へのお礼

どうもありがとうございます。
マクロの勉強になりました。

お礼日時：2010/05/11 16:48

No.2 回答者： KURUMITO 回答日時： 2010/05/11 14:39

マクロを使わなくとも次のようにすればよいでしょう。

元の表がシート1のＡ列からＦ列に有り、1，2行目は項目名でデータが3行目から下方にあるとします。
お求めの表をシート2に作るとしてＡ1セルからＪ1セルまでに項目が並んで入力されているとします。
Ａ2セルには次の式を入力して右横方向にオートフィルドラッグしたのちに下方向にもオートフィルドラッグします。

=IF(OR(A$1="",ROW(A1)>(COUNTA(Sheet1!$A:$A)-2)/2),"",INDEX(Sheet1!$A:$F,ROW(A1)*2+1+IF(COLUMN(A1)<6,IF(MOD(COLUMN(A1),2)=0,1,0),IF(COLUMN(A1)>6,IF(MOD(COLUMN(A1),2)=0,1,0))),IF(COLUMN(A1)<=5,ROUNDUP(COLUMN(A1)/2,0),IF(COLUMN(A1)=6,4,ROUNDUP((COLUMN(A1)+2)/2,0)))))

この回答へのお礼

どうもありがとうございます。
考え方はよくわかりましたが、うまくいきませんでした。
けれども関数の記入方等は参考になりましたので、次に活かせそうです。

お礼日時：2010/05/11 16:50