Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


9803 / 76734 ←次へ | 前へ→

【72488】Re:sheet1のデータをsheet2に整形して抽出する方法
お礼  タケル  - 12/8/15(水) 22:36 -

引用なし
パスワード
   UO3さんへ
欲しい処理ができました。
ありがとうございます。
ただ、もう少しこうしたほうが処理が速くなるとか、
何かアドバイスがいただければ幸いです。

それから、sheet1にデータがなくなったときに
処理を終わらせるためには、どうしたらよろしいでしょうか?

--------------------------------------------------------------------------

Sub コピペ()

i = 2
j = 2

m = 2
n = 3
o = 4
p = 5
q = 6
r = 7

p01:
If Cells(i, "A") = "" Then
   Sheets(1).Cells(i + 1, "A").Copy Sheets(2).Cells(j, "A")
   Sheets("sheet2").Select
   Sheets(2).Range(Cells(j, "A"), Cells(j + 5, "A")).MergeCells = True 'アプリケーション定義またはオブジェクト定義のエラー(上手く行く時もある)
   Sheets("sheet1").Select
  
   Sheets(1).Cells(i + 1, "B").Copy Sheets(2).Cells(j, "B")
   Sheets("sheet2").Select
   Sheets(2).Range(Cells(j, "B"), Cells(j + 5, "B")).MergeCells = True
   Sheets("sheet1").Select

   Sheets(1).Cells(i + 1, "J").Copy Sheets(2).Cells(j + 1, "V")
   Sheets(1).Cells(i + 1, "K").Copy Sheets(2).Cells(j + 3, "V")
   Sheets(1).Cells(i + 2, "K").Copy Sheets(2).Cells(j + 4, "V")
   Sheets(1).Cells(i + 3, "K").Copy Sheets(2).Cells(j + 5, "V")
     
   j = j + 6

   Y = Sheets("sheet1").Cells(i + 1, "B").Value
  
   Sheets(1).Range(Cells(i + 1, "D"), Cells(i + Y, "D")).Select
   Selection.Copy
   Sheets(2).Select
   Range(Cells(m, 4), Cells(m, 4 + Y)).Select
   Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
    False, Transpose:=True
   m = m + 6
   Sheets("sheet1").Select
  
  
   Sheets(1).Range(Cells(i + 1, "E"), Cells(i + Y, "E")).Select 'アプリケーション定義またはオブジェクト定義のエラーが発生
   Selection.Copy
   Sheets(2).Select
   Range(Cells(n, 4), Cells(n, 4 + Y)).Select
   Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
    False, Transpose:=True
   n = n + 6
   Sheets("sheet1").Select
  
   Sheets(1).Range(Cells(i + 1, "F"), Cells(i + Y, "F")).Select
   Selection.Copy
   Sheets(2).Select
   Range(Cells(o, 4), Cells(o, 4 + Y)).Select
   Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
    False, Transpose:=True
   o = o + 6
   Sheets("sheet1").Select
  
   Sheets(1).Range(Cells(i + 1, "G"), Cells(i + Y, "G")).Select
   Selection.Copy
   Sheets(2).Select
   Range(Cells(p, 4), Cells(p, 4 + Y)).Select
   Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
    False, Transpose:=True
   p = p + 6
   Sheets("sheet1").Select
  
   Sheets(1).Range(Cells(i + 1, "H"), Cells(i + Y, "H")).Select
   Selection.Copy
   Sheets(2).Select
   Range(Cells(q, 4), Cells(q, 4 + Y)).Select
   Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
    False, Transpose:=True
   q = q + 6
   Sheets("sheet1").Select
  
   Sheets(1).Range(Cells(i + 1, "I"), Cells(i + Y, "I")).Select
   Selection.Copy
   Sheets(2).Select
   Range(Cells(r, 4), Cells(r, 4 + Y)).Select
   Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
    False, Transpose:=True
   r = r + 6
   Sheets("sheet1").Select
  
Else
End If
i = i + 1
GoTo p01
End Sub

--------------------------------------------------------------------------
3 hits

【72481】sheet1のデータをsheet2に整形して抽出する方法 タケル 12/8/15(水) 14:45 質問
【72484】Re:sheet1のデータをsheet2に整形して抽出... UO3 12/8/15(水) 19:54 発言
【72487】Re:sheet1のデータをsheet2に整形して抽出... タケル 12/8/15(水) 22:17 回答
【72488】Re:sheet1のデータをsheet2に整形して抽出... タケル 12/8/15(水) 22:36 お礼
【72496】Re:sheet1のデータをsheet2に整形して抽出... kanabun 12/8/16(木) 9:28 発言
【72501】Re:sheet1のデータをsheet2に整形して抽出... UO3 12/8/16(木) 15:57 発言
【72490】Re:sheet1のデータをsheet2に整形して抽出... UO3 12/8/15(水) 22:40 発言

9803 / 76734 ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free