マンガでよめる痔のこと・薬のこと

Excel 2010でSheet1に次のような表があります。

 A列  B列 C列 D列 E列
 りんご 111  222 333 444
 みかん 555  666
 いちご 777  888 999
  ・
  ・
  ・
これをマクロを使って、次のような形にしたいと思います。
1.C列以降の「数値が入った列数分だけ」行コピーをする。(最大9列まで)
 (この例の場合りんごの行は3回、みかんの行は1回、いちごの行は2回)
2.次にC列以降の数値はコピーした行のB列に移動する。

マクロ実行後は次のようになります。
 A列  B列
 りんご 111
 りんご 222
 りんご 333
 りんご 444
 みかん 555
 みかん 666
 いちご 777
 いちご 888
 いちご 999
  ・
  ・
  ・
膨大な数のデータですので、マクロを使って処理したいと思っています。
どうぞよろしくお願いいたします。

このQ&Aに関連する最新のQ&A

A 回答 (9件)

こんばんは!


お望みの方法と違うかもしれませんが・・・
別Sheetに表示する方法の一例です。
Sheet1のデータをSheet2に表示するようにしてみました。

尚、データは2行目からとしています。

Sub test()
Dim i, j As Long
Dim ws1, ws2 As Worksheet
Set ws1 = Worksheets("sheet1")
Set ws2 = Worksheets("sheet2")
For i = 2 To ws1.Cells(Rows.Count, 1).End(xlUp).Row
'↑データが1行目からの場合は「2」を「1」に変更
For j = 2 To ws1.Cells(i, Columns.Count).End(xlToLeft).Column
With ws2.Cells(Rows.Count, 1).End(xlUp).Offset(1)
.Value = ws1.Cells(i, 1)
.Offset(, 1) = ws1.Cells(i, j)
End With
Next j
Next i
End Sub

こんな感じではどうでしょうか?m(_ _)m

この回答への補足

回答ありがとうございます。この方法が元データもSheet1に残っていて、1番良いように思います。
実際のデータはB~K列の10列に各支店での商品在庫数が入ってきます。間違って元データのL列にも数値が入っていた場合も、行コピーと数値の移動はされるのでしょうか。

補足日時:2011/07/03 01:44
    • good
    • 0

No.5・6・7です!



補足を読ませていただきました。

実際仕事で使っている表はいろいろな項目があり、数値を移動させる列はH列以降となり、A~F列までの内容が行コピーされるというふうにしたいのです

と言うコトですので・・・
↓の画像のような感じでよいのでしょうかね?
もしそうであれば無理矢理って感じのコードです。
For~Nextを多用していますので結構時間がかかるかもしれません。

Sub test()
Dim i, j, k As Long
Dim ws1, ws2 As Worksheet
Set ws1 = Worksheets("sheet1")
Set ws2 = Worksheets("sheet2")
ws2.Cells.Clear
Range(ws1.Cells(1, 1), ws1.Cells(1, 7)).Copy
ws2.Activate
ws2.Cells(1, 1).Select
ActiveSheet.Paste
Application.CutCopyMode = False
For i = 2 To ws1.Cells(Rows.Count, 1).End(xlUp).Row
For j = 8 To ws1.Cells(i, Columns.Count).End(xlToLeft).Column
With ws2.Cells(Rows.Count, 7).End(xlUp).Offset(1)
.Value = ws1.Cells(i, 7)
.Offset(, 1) = ws1.Cells(i, j)
End With
Next j
Next i
For i = 2 To ws1.Cells(Rows.Count, 1).End(xlUp).Row
For j = 2 To ws2.Cells(Rows.Count, 7).End(xlUp).Row
For k = 1 To 6
If ws1.Cells(i, 7) = ws2.Cells(j, 7) Then
ws2.Cells(j, k) = ws1.Cells(i, k)
End If
Next k
Next j
Next i
ws2.Columns("A:H").AutoFit
End Sub

尚、各行のデータがある最終列までを表示するようにしていますので、
もしSheet1の列数に指定がある場合は

>For j = 8 To ws1.Cells(i, Columns.Count).End(xlToLeft).Column

部分で調整してみてください。
(「8列目~その行の最終列まで」というコードになります)

以上、長々と失礼しました。m(_ _)m
「Excel 指定値だけ行コピー+値の移動」の回答画像9
    • good
    • 0
この回答へのお礼

スクリーンキャプチャまで使って説明していただき、ありがとうございます。

>For~Nextを多用していますので結構時間がかかるかもしれません。
やはり複雑になってしまうのですね。結局、質問にあるように最低限の項目だけに表を加工してから、次のようにするのが良いのかもしれません。
1.No.5のマクロを実行
2.項目(列)を挿入
3.空白のセルに元データからvlookup関数で値を挿入する。

とても丁寧な回答ありがとうございました。

お礼日時:2011/07/03 19:28

>実行時エラー



ご質問で掲示されたのとは違うパターンで数字が入っている(入っていない)ようです。

sub macro1r1()
 dim r as long
 dim n as long

 for r = range("B65536").end(xlup).row to 1 step -1
  n = application.count(range(cells(r, "C"), cells(r, "K")))
  if n > 0 then
  cells(r + 1, "A").resize(n, 1).entirerow.insert
  cells(r + 1, "A").resize(n, 1).value = cells(r ,"A").value
  cells(r, "C").resize(1, n).copy
  cells(r + 1, "B").pastespecial transpose:=true
  end if
 next r
 range("C:K").delete shift:=xlshifttoleft
end sub



#まぁ,使わないのでしたら捨ててくださいとしか言いようがありませんが。
    • good
    • 0
この回答へのお礼

補足への回答ありがとうございます。
今回は急ぎで処理しなければならないデータのため、結果ばかりを追い求めてしまいましたが、今後はステートメントの意味を理解して自分で応用できるようになりたいと思います。

お礼日時:2011/07/03 19:38

No.5・6です!


何度もごめんなさい。

No.6のコードで
>Do Until L = i + j - 1
の行を
>Do Until L = i + k - 1
に訂正してください。

検証せずに投稿してごめんなさいね。m(_ _)m

この回答への補足

tom04さん、訂正ありがとうございます。
実際仕事で使っている表はいろいろな項目があり、数値を移動させる列はH列以降となり、A~F列までの内容が行コピーされるというふうにしたいのです。

No.5の別シートに出力する方法で、どういう風にマクロを変更すればよいのか教えていただけますでしょうか。

補足日時:2011/07/03 03:25
    • good
    • 0

No.5です!


もう一案

同一Sheetで処理する場合のコードの一例です。
今回もデータは2行目からとしています。

Sub test2()
Dim i, j, k, L As Long
For i = Cells(Rows.Count, 1).End(xlUp).Row To 2 Step -1
'↑データが1行目からであれば「2」を「1」に変更
j = Cells(i, Columns.Count).End(xlToLeft).Column
If j > 2 Then
Rows(i + 1 & ":" & i + j - 2).Insert
End If
L = i + 1
For k = 3 To j
Do Until L = i + j - 1
With Cells(L, 1)
.Value = Cells(i, 1)
.Offset(, 1) = Cells(i, k)
End With
L = L + 1
Loop
Next k
Next i
Columns("C:K").Delete
End Sub

何度も失礼しました。m(_ _)m
    • good
    • 0
この回答へのお礼

ありがとうございます。
質問した時点では、この回答のように元データを変更するマクロを考えていたのですが、No.5の別シートに出力する方法も良いですね。
マクロについていろいろ勉強になりました。これでだいぶ仕事がはかどります。

お礼日時:2011/07/03 02:23

回答No1です。


失礼しました。別のシートのA2セルには次の式を入力しB2セルまでオートフィルドラッグしたのちに下方にもオートフィルドラッグします。

=IF(ROW(A1)>MAX(Sheet1!$J:$J),"",IF(COLUMN(A1)=1,INDEX(Sheet1!$A:$A,MATCH(ROW(A1)-1,Sheet1!$J:$J,TRUE)+1),INDEX(Sheet1!$A:$I,MATCH(ROW(A1)-1,Sheet1!$J:$J,TRUE)+1,COUNTIF($A$2:$A2,$A2)+1)))
    • good
    • 0

Sub test01()


Dim sh1, sh2
Set sh1 = Worksheets("Sheet1")
Set sh2 = Worksheets("Sheet2")
d = sh1.Range("a65536").End(xlUp).Row
k = 1
For i = 1 To d
c = sh1.Range("z" & i).End(xlToLeft).Column
'MsgBox c
For Each cl In sh1.Range(sh1.Cells(i, 2), sh1.Cells(i, c))
MsgBox cl
sh2.Cells(k, "A") = sh1.Cells(i, "A")
sh2.Cells(k, "B") = cl
k = k + 1
Next
Next i
End Sub
ーー
最も右の列は「Z列を仮定、適当に変えて。

この回答への補足

回答ありがとうございます。

試したところ、sheet2に出力されるのですが、B列以降の内容が全てメッセージボックスに表示されてしまいます。
今回はtom04さんのマクロを使用してみることにしますが、参考にさせていただきます。
素早い回答ありがとうございました。

補足日時:2011/07/03 02:19
    • good
    • 0

sub macro1()


 dim r as long
 dim n as long

 for r = range("B65536").end(xlup).row to 1 step -1
  n = application.count(range(cells(r, "C"), cells(r, "K")))
  cells(r + 1, "A").resize(n, 1).entirerow.insert
  cells(r + 1, "A").resize(n, 1).value = cells(r ,"A").value
  cells(r, "C").resize(1, n).copy
  cells(r + 1, "B").pastespecial transpose:=true
 next r
 range("C:K").delete shift:=xlshifttoleft
end sub

この回答への補足

回答ありがとうございます。

試してみたところ、値の「移動」ではなく「コピー」となってしまうようです。
また、実行時エラー'1004':アプリケーション定義またはオブジェクト定義のエラーです。
と表示されてしまいます。

補足日時:2011/07/03 01:59
    • good
    • 0

マクロを使わなくとも関数で十分対応できますね。


次のようにします。
お示しのデータがシート1に有って1行目は項目名で2行目以降に各データが入力されているとします。
10列目のJ列は作業列としてJ1セルには0を入力します。その後にJ2セルには次の式を入力して下方にオートフィルドラッグします。

=IF(A2="","",COUNTA(B2:I2)+J1)

データが多くてオートフィルドラッグが容易でなければJ2セルを選択して右クリックから「コピー」したのちに「名前ボックス」にJ2と表示されているところで例えばJ2:J5000と入力してEnterをすれば2行目から5000行まで選択状態になりますので右クリックして貼り付けをすればJ2セルからJ5000までオートフィルドラッグ操作を行ったことになります。

その後にお求めの表ですが別のシートに表示させるとして1行目はシート1と同じ項目名としてA2セルには次の式を入力してI2セルまでオートフィルドラッグしたのちに下方にもオートフィルドラッグします。

=IF(ROW(A1)>MAX(Sheet1!$J:$J),"",IF(COLUMN(A1)=1,INDEX(Sheet1!$A:$A,MATCH(ROW(A1)-1,Sheet1!$J:$J,TRUE)+1),IF(INDEX(Sheet1!$A:$I,MATCH(ROW(A1)-1,Sheet1!$J:$J,TRUE)+1,COLUMN(A1))=0,"",INDEX(Sheet1!$A:$I,MATCH(ROW(A1)-1,Sheet1!$J:$J,TRUE)+1,COLUMN(A1)))))

これでお求めの表が完成します。
    • good
    • 0
この回答へのお礼

回答ありがとうございます。

マクロを使わなければできないと思っていただけに、関数だけでできるとは気がつきませんでした。こちらも参考にさせていただきます。

素早い回答ありがとうございました。この考え方を元にいろいろ応用できそうですね。

お礼日時:2011/07/03 02:29

このQ&Aに関連する人気のQ&A

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

このQ&Aを見た人が検索しているワード


人気Q&Aランキング