Excel VBA質問箱 IV

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

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

  新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム  
2706 / 13645 ﾂﾘｰ ←次へ　｜　前へ→
▼ 【66485】ループ処理を教えてください Gobou 10/9/5(日) 23:27 質問[未読]
【66487】Re:ループ処理を教えてください Hirofumi 10/9/6(月) 5:18 回答[未読]
【66488】Re:ループ処理を教えてください Hirofumi 10/9/6(月) 6:10 回答[未読]
【66489】Re:ループ処理を教えてください Yuki 10/9/6(月) 15:43 発言[未読]
【66485】ループ処理を教えてください
質問  Gobou  - 10/9/5(日) 23:27 -
引用なし
パスワード
   もし、あシートのG1セルがＡの場合には
　あシートの1列目には、いシートの1列目がコピーされる
　あシートの2列目には、うシートの1列目がコピーされる
　あシートの3列目には、えシートの1列目がコピーされる
　あシートの4列目には、おEシートの1列目がコピーされる
あシートのG1セルがＢの場合には
　あシートの1列目には、いシートの2列目がコピーされる
　あシートの2列目には、うシートの2列目がコピーされる
　あシートの3列目には、えシートの2列目がコピーされる
　あシートの4列目には、おEシートの2列目がコピーされる
あシートのG1セルがＣの場合には
　あシートの1列目には、いシートの3列目がコピーされる
　あシートの2列目には、うシートの3列目がコピーされる
　あシートの3列目には、えシートの3列目がコピーされる
　あシートの4列目には、おEシートの3列目がコピーされる

としたい。
しかし、ループ処理が苦手なので、以下のようになってしまった。
ループ処理を使う場合。どう書くとよいのですか？


Sub sample()
　If Worksheets("あ").Range("G1") = "Ａ" Then
　 Worksheets("い").Range("A:A").Copy Destination:=Worksheets("あ").Range("A:A")
　 Worksheets("う").Range("A:A").Copy Destination:=Worksheets("あ").Range("B:B")
　 Worksheets("え").Range("A:A").Copy Destination:=Worksheets("あ").Range("C:C")
　 Worksheets("お").Range("A:A").Copy Destination:=Worksheets("あ").Range("D:D")
　End If
　If Worksheets("あ").Range("G1") = "Ｂ" Then
　 Worksheets("い").Range("B:B").Copy Destination:=Worksheets("あ").Range("A:A")
　 Worksheets("う").Range("B:B").Copy Destination:=Worksheets("あ").Range("B:B")
　 Worksheets("え").Range("B:B").Copy Destination:=Worksheets("あ").Range("C:C")
　 Worksheets("お").Range("B:B").Copy Destination:=Worksheets("あ").Range("D:D")
　End If
　If Worksheets("あ").Range("G1") = "Ｃ" Then
　 Worksheets("い").Range("C:C").Copy Destination:=Worksheets("あ").Range("A:A")
　 Worksheets("う").Range("C:C").Copy Destination:=Worksheets("あ").Range("B:B")
　 Worksheets("え").Range("C:C").Copy Destination:=Worksheets("あ").Range("C:C")
　 Worksheets("お").Range("C:C").Copy Destination:=Worksheets("あ").Range("D:D")
　End If
End Sub
【66487】Re:ループ処理を教えてください
回答  Hirofumi  - 10/9/6(月) 5:18 -
引用なし
パスワード
   こんなのでは

Option Explicit

Public Sub Sample_1()

　　With Worksheets("あ")
　　　　Select Case .Range("G1").Value
　　　　　　Case Is = "Ａ"
　　　　　　　　Worksheets("い").Columns(1).Copy Destination:=.Columns(1)
　　　　　　　　Worksheets("う").Columns(1).Copy Destination:=.Columns(2)
　　　　　　　　Worksheets("え").Columns(1).Copy Destination:=.Columns(3)
　　　　　　　　Worksheets("お").Columns(1).Copy Destination:=.Columns(4)
　　　　　　Case Is = "Ｂ"
　　　　　　　　Worksheets("い").Columns(2).Copy Destination:=.Columns(1)
　　　　　　　　Worksheets("う").Columns(2).Copy Destination:=.Columns(2)
　　　　　　　　Worksheets("え").Columns(2).Copy Destination:=.Columns(3)
　　　　　　　　Worksheets("お").Columns(2).Copy Destination:=.Columns(4)
　　　　　　Case Is = "Ｃ"
　　　　　　　　Worksheets("い").Columns(3).Copy Destination:=.Columns(1)
　　　　　　　　Worksheets("う").Columns(3).Copy Destination:=.Columns(2)
　　　　　　　　Worksheets("え").Columns(3).Copy Destination:=.Columns(3)
　　　　　　　　Worksheets("お").Columns(3).Copy Destination:=.Columns(4)
　　　　End Select
　　End With
　　
End Sub

Public Sub Sample_2()

　　Dim vntSheets As Variant
　　
　　vntSheets = Array("い", "う", "え", "お")
　　
　　With Worksheets("あ")
　　　　Select Case .Range("G1").Value
　　　　　　Case Is = "Ａ"
　　　　　　　　Worksheets(vntSheets(0)).Columns(1).Copy _
　　　　　　　　　　　　Destination:=.Columns(1)
　　　　　　　　Worksheets(vntSheets(1)).Columns(1).Copy _
　　　　　　　　　　　　Destination:=.Columns(2)
　　　　　　　　Worksheets(vntSheets(2)).Columns(1).Copy _
　　　　　　　　　　　　Destination:=.Columns(3)
　　　　　　　　Worksheets(vntSheets(3)).Columns(1).Copy _
　　　　　　　　　　　　Destination:=.Columns(4)
　　　　　　Case Is = "Ｂ"
　　　　　　　　Worksheets(vntSheets(0)).Columns(2).Copy _
　　　　　　　　　　　　Destination:=.Columns(1)
　　　　　　　　Worksheets(vntSheets(1)).Columns(2).Copy _
　　　　　　　　　　　　Destination:=.Columns(2)
　　　　　　　　Worksheets(vntSheets(2)).Columns(2).Copy _
　　　　　　　　　　　　Destination:=.Columns(3)
　　　　　　　　Worksheets(vntSheets(3)).Columns(2).Copy _
　　　　　　　　　　　　Destination:=.Columns(4)
　　　　　　Case Is = "Ｃ"
　　　　　　　　Worksheets(vntSheets(0)).Columns(3).Copy _
　　　　　　　　　　　　Destination:=.Columns(1)
　　　　　　　　Worksheets(vntSheets(1)).Columns(3).Copy _
　　　　　　　　　　　　Destination:=.Columns(2)
　　　　　　　　Worksheets(vntSheets(2)).Columns(3).Copy _
　　　　　　　　　　　　Destination:=.Columns(3)
　　　　　　　　Worksheets(vntSheets(3)).Columns(3).Copy _
　　　　　　　　　　　　Destination:=.Columns(4)
　　　　End Select
　　End With
　　
End Sub

Public Sub Sample_3()

　　Dim i As Long
　　Dim vntSheets As Variant
　　
　　vntSheets = Array("い", "う", "え", "お")
　　
　　With Worksheets("あ")
　　　　Select Case .Range("G1").Value
　　　　　　Case Is = "Ａ"
　　　　　　　　For i = 0 To UBound(vntSheets, 1)
　　　　　　　　　　Worksheets(vntSheets(i)).Columns(1).Copy _
　　　　　　　　　　　　　　Destination:=.Columns(i + 1)
　　　　　　　　Next i
　　　　　　Case Is = "Ｂ"
　　　　　　　　For i = 0 To UBound(vntSheets, 1)
　　　　　　　　　　Worksheets(vntSheets(i)).Columns(2).Copy _
　　　　　　　　　　　　　　Destination:=.Columns(i + 1)
　　　　　　　　Next i
　　　　　　Case Is = "Ｃ"
　　　　　　　　For i = 0 To UBound(vntSheets, 1)
　　　　　　　　　　Worksheets(vntSheets(i)).Columns(3).Copy _
　　　　　　　　　　　　　　Destination:=.Columns(i + 1)
　　　　　　　　Next i
　　　　End Select
　　End With
　　
End Sub

Public Sub Sample_4()

　　Dim i As Long
　　Dim j As Long
　　Dim vntMark As Variant
　　Dim vntSheets As Variant
　　Dim vntComp As Variant
　　
　　vntSheets = Array("い", "う", "え", "お")
　　vntComp = Array("Ａ", "Ｂ", "Ｃ")
　　
　　With Worksheets("あ")
　　　　vntMark = .Range("G1").Value
　　　　For i = 0 To UBound(vntComp, 1)
　　　　　　If vntMark = vntComp(i) Then
　　　　　　　　Exit For
　　　　　　End If
　　　　Next i
　　　　'条件以内なら
　　　　If i <= UBound(vntComp, 1) Then
　　　　　　For j = 0 To UBound(vntSheets, 1)
　　　　　　　　Worksheets(vntSheets(j)).Columns(i + 1).Copy _
　　　　　　　　　　　　Destination:=.Columns(j + 1)
　　　　　　Next j
　　　　End If
　　End With
　　
End Sub
【66488】Re:ループ処理を教えてください
回答  Hirofumi  - 10/9/6(月) 6:10 -
引用なし
パスワード
   あ！、「Sub Sample_4」は

Public Sub Sample_5()

　　Dim i As Long
　　Dim j As Long
　　Dim vntMark As Variant
　　Dim vntSheets As Variant
　　Dim vntComp As Variant
　　
　　vntSheets = Array("い", "う", "え", "お")
　　vntComp = Array("Ａ", "Ｂ", "Ｃ")
　　
　　With Worksheets("あ")
　　　　vntMark = .Range("G1").Value
　　　　For i = 0 To UBound(vntComp, 1)
　　　　　　If vntMark = vntComp(i) Then
　　　　　　　　For j = 0 To UBound(vntSheets, 1)
　　　　　　　　　　Worksheets(vntSheets(j)).Columns(i + 1).Copy _
　　　　　　　　　　　　　　Destination:=.Columns(j + 1)
　　　　　　　　Next j
　　　　　　　　Exit For
　　　　　　End If
　　　　Next i
　　End With
　　
End Sub

と書くのが一般的なのかも解りませんが（If文が1つ少ない）
もし、入力が条件に合わない場合等

Public Sub Sample_6()

　　Dim i As Long
　　Dim j As Long
　　Dim vntMark As Variant
　　Dim vntSheets As Variant
　　Dim vntComp As Variant
　　
　　vntSheets = Array("い", "う", "え", "お")
　　vntComp = Array("Ａ", "Ｂ", "Ｃ")
　　
　　With Worksheets("あ")
　　　　vntMark = .Range("G1").Value
　　　　For i = 0 To UBound(vntComp, 1)
　　　　　　If vntMark = vntComp(i) Then
　　　　　　　　Exit For
　　　　　　End If
　　　　Next i
　　　　'条件以内なら
　　　　If i <= UBound(vntComp, 1) Then
　　　　　　For j = 0 To UBound(vntSheets, 1)
　　　　　　　　Worksheets(vntSheets(j)).Columns(i + 1).Copy _
　　　　　　　　　　　　Destination:=.Columns(j + 1)
　　　　　　Next j
　　　　Else
　　　　　　MsgBox "G1セルの入力が条件に合いません", vbInformation
　　　　End If
　　End With
　　
End Sub

合う場合と合わない場合で並べて書けるので、私は「Sample_4」の様に書きます
【66489】Re:ループ処理を教えてください
発言  Yuki  - 10/9/6(月) 15:43 -
引用なし
パスワード
   ▼Gobou さん

こんな感じでしょうか。

Sub TESTe()
　　Dim ary　　 As Variant
　　Dim col　　 As Long
　　Dim i　　　 As Long
　　Dim sht　　 As Worksheet
　　
　　Set sht = Worksheets("あ")
　　ary = Array("い", "う", "え", "お")
　　col = Columns(sht.Range("G1").Value).Column
　　For i = 0 To UBound(ary)
　　　　Worksheets(ary(i)).Columns(col).Copy sht.Columns(i + 1)
　　Next
End Sub
  新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム  
2706 / 13645 ﾂﾘｰ ←次へ　｜　前へ→
ページ：  ┃  記事番号：
2610219
(SS)C-BOARD v3.8 is Free