Excel VBA質問箱 IV

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

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


	新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム

5881 / 76807

←次へ　｜　前へ→


	【76533】Re:コードを短くしたい

β - 14/12/27(土) 16:22 -


	引用なし

	パスワード

▼ゆーあさん：

それでは、コードを３つアップします。

その前に、

ActiveCell や Selection や ActiveSheet や ActiveWorkbook を前提にした
コードは極力避けることが推奨されます。
VBAコードでは、これらを前提にしなくても（９９．９％ぐらいは）ブックやシートやセルを特定できます。
もちろん、ActiveCell というものは、ActiveSheet上にしかなく、また、ほかのコードの書き方では
参照できない、そんなものもあるにはありますが、これらは例外です。

今後、デバッグ等の目的でステップ実行しながら処理の途中経過を確認していく、そういった作業の中で
裏に隠れていたブックを確認したり、裏に隠れていたシートを確認したりするでしょう。
で、確認後、ステップ実行を継続すると、ActiveWorkbookが本来のものとは異なっていたり、あるいは
ActiveSheetが本来のものとは異なっていたり、そんなことが往々にして発生し、とんでもない障害になる
可能性があります。

ですから、コード内では、極力、今相手にしているブック、シート、セルを特定して記述することが
重要です。

前置きは以上。

SampleA が　すでにアップした Sample　に相当します。
１項目ごとに転記コードを書いたものです。
でも、そちらで、今使っているコード（２つのブックを１項目ごとにアクティブにして処理するコード）
より、数段早いはずです。

SampleB は、基本的には　SampleA と同じ発想です。
ただ、元データの連続した４列（４セル）を新データの連続した４列（４セル）に転記するところを
１行で、（１セルの転記ではなく）４セル領域の転記として書いています。
コードも短くなりますし、セルへの書き込み回数も減少しますので、SampleA より処理効率がアップします。

で、今回のデータから見て、この SampleB で十分だと思いますが、参考までに、SampleB での転記を
ループさせて書き込むコードを SampleC としてアップします。
コード数は少なくなりますが、実は、処理効率としては SampleB と同じか、ループ制御のための処理で
ほんのわずか、効率が落ちるかも。

ただ、ループ処理の１つの例として参考までにお届けします。

Sub SampleA()
　　Dim i As Long
　　'元ブックと元シート
　　Dim dBK As Workbook
　　Dim dSh As Worksheet
　　'転記ブックと転記シート
　　Dim nBK As Workbook
　　Dim nSh As Worksheet
'--------------------------------------------
　　Set dBK = ThisWorkbook
　　Set dSh = dBK.Sheets("Sheet3")
　　
　　'Just In Case
　　If Not ActiveSheet Is dSh Then
　　　　MsgBox dSh.Name & "をアクティブにしてから実行してください"
　　　　Exit Sub
　　End If
　　
　　Application.ScreenUpdating = False　　　'セル書き込みに伴う画面再描画の抑止（処理時間の短縮化）
　　
　　i = ActiveCell.Row　　　'抽出すべき行番号
　　Set nBK = Workbooks.Add(xlWBATWorksheet)
　　Set nSh = nBK.Sheets(1)
　　nSh.Name = "ﾃﾞｰﾀ抽出"
　　
　　nSh.Range("B6").Value = dSh.Cells(i, 1).Value
　　nSh.Range("C6").Value = dSh.Cells(i, 2).Value
　　nSh.Range("D6").Value = dSh.Cells(i, 3).Value
　　nSh.Range("E6").Value = dSh.Cells(i, 4).Value
　　nSh.Range("H6").Value = dSh.Cells(i, 5).Value
　　nSh.Range("B11").Value = dSh.Cells(i, 6).Value
　　nSh.Range("C11").Value = dSh.Cells(i, 7).Value
　　nSh.Range("D11").Value = dSh.Cells(i, 8).Value
　　nSh.Range("E11").Value = dSh.Cells(i, 9).Value
　　nSh.Range("H11").Value = dSh.Cells(i, 10).Value
　　nSh.Range("B16").Value = dSh.Cells(i, 11).Value
　　nSh.Range("C16").Value = dSh.Cells(i, 12).Value
　　nSh.Range("D16").Value = dSh.Cells(i, 13).Value
　　nSh.Range("E16").Value = dSh.Cells(i, 14).Value
　　nSh.Range("H16").Value = dSh.Cells(i, 15).Value
　　nSh.Range("B21").Value = dSh.Cells(i, 16).Value
　　nSh.Range("C21").Value = dSh.Cells(i, 17).Value
　　nSh.Range("D21").Value = dSh.Cells(i, 18).Value
　　nSh.Range("E21").Value = dSh.Cells(i, 19).Value
　　nSh.Range("H21").Value = dSh.Cells(i, 20).Value
　　nSh.Range("B26").Value = dSh.Cells(i, 21).Value
　　nSh.Range("C26").Value = dSh.Cells(i, 22).Value
　　nSh.Range("D26").Value = dSh.Cells(i, 23).Value
　　nSh.Range("E26").Value = dSh.Cells(i, 24).Value
　　nSh.Range("H26").Value = dSh.Cells(i, 25).Value
　　nSh.Range("B31").Value = dSh.Cells(i, 26).Value
　　nSh.Range("C31").Value = dSh.Cells(i, 27).Value
　　nSh.Range("D31").Value = dSh.Cells(i, 28).Value
　　nSh.Range("E31").Value = dSh.Cells(i, 29).Value
　　nSh.Range("H31").Value = dSh.Cells(i, 30).Value
　　nSh.Range("B36").Value = dSh.Cells(i, 31).Value
　　nSh.Range("C36").Value = dSh.Cells(i, 32).Value
　　nSh.Range("D36").Value = dSh.Cells(i, 33).Value
　　nSh.Range("E36").Value = dSh.Cells(i, 34).Value
　　nSh.Range("H36").Value = dSh.Cells(i, 35).Value
　　nSh.Range("B41").Value = dSh.Cells(i, 36).Value
　　nSh.Range("C41").Value = dSh.Cells(i, 37).Value
　　nSh.Range("D41").Value = dSh.Cells(i, 38).Value
　　nSh.Range("E41").Value = dSh.Cells(i, 39).Value
　　nSh.Range("H41").Value = dSh.Cells(i, 40).Value
　　nSh.Range("B46").Value = dSh.Cells(i, 41).Value
　　nSh.Range("C46").Value = dSh.Cells(i, 42).Value
　　nSh.Range("D46").Value = dSh.Cells(i, 43).Value
　　nSh.Range("E46").Value = dSh.Cells(i, 44).Value
　　nSh.Range("H46").Value = dSh.Cells(i, 45).Value
　　nSh.Range("B51").Value = dSh.Cells(i, 46).Value
　　nSh.Range("C51").Value = dSh.Cells(i, 47).Value
　　nSh.Range("D51").Value = dSh.Cells(i, 48).Value
　　nSh.Range("E51").Value = dSh.Cells(i, 49).Value
　　nSh.Range("H51").Value = dSh.Cells(i, 50).Value
　　
　　　　　
End Sub

Sub SampleB()
　　Dim i As Long
　　'元ブックと元シート
　　Dim dBK As Workbook
　　Dim dSh As Worksheet
　　'転記ブックと転記シート
　　Dim nBK As Workbook
　　Dim nSh As Worksheet
'--------------------------------------------
　　Set dBK = ThisWorkbook
　　Set dSh = dBK.Sheets("Sheet3")
　　
　　'Just In Case
　　If Not ActiveSheet Is dSh Then
　　　　MsgBox dSh.Name & "をアクティブにしてから実行してください"
　　　　Exit Sub
　　End If
　　
　　Application.ScreenUpdating = False　　　'セル書き込みに伴う画面再描画の抑止（処理時間の短縮化）
　　
　　i = ActiveCell.Row　　　'抽出すべき行番号
　　Set nBK = Workbooks.Add(xlWBATWorksheet)
　　Set nSh = nBK.Sheets(1)
　　nSh.Name = "ﾃﾞｰﾀ抽出"
　　
　　nSh.Range("B6").Resize(, 4).Value = dSh.Cells(i, 1).Resize(, 4).Value
　　nSh.Range("H6").Value = dSh.Cells(i, 5).Value
　　nSh.Range("B11").Resize(, 4).Value = dSh.Cells(i, 6).Resize(, 4).Value
　　nSh.Range("H11").Value = dSh.Cells(i, 10).Value
　　nSh.Range("B16").Resize(, 4).Value = dSh.Cells(i, 11).Resize(, 4).Value
　　nSh.Range("H16").Value = dSh.Cells(i, 15).Value
　　nSh.Range("B21").Resize(, 4).Value = dSh.Cells(i, 16).Resize(, 4).Value
　　nSh.Range("H21").Value = dSh.Cells(i, 20).Value
　　nSh.Range("B26").Resize(, 4).Value = dSh.Cells(i, 21).Resize(, 4).Value
　　nSh.Range("H26").Value = dSh.Cells(i, 25).Value
　　nSh.Range("B31").Resize(, 4).Value = dSh.Cells(i, 26).Resize(, 4).Value
　　nSh.Range("H31").Value = dSh.Cells(i, 30).Value
　　nSh.Range("B36").Resize(, 4).Value = dSh.Cells(i, 31).Resize(, 4).Value
　　nSh.Range("H36").Value = dSh.Cells(i, 35).Value
　　nSh.Range("B41").Resize(, 4).Value = dSh.Cells(i, 36).Resize(, 4).Value
　　nSh.Range("H41").Value = dSh.Cells(i, 40).Value
　　nSh.Range("B46").Resize(, 4).Value = dSh.Cells(i, 41).Resize(, 4).Value
　　nSh.Range("H46").Value = dSh.Cells(i, 45).Value
　　nSh.Range("B51").Resize(, 4).Value = dSh.Cells(i, 46).Resize(, 4).Value
　　nSh.Range("H51").Value = dSh.Cells(i, 50).Value
　　
　　　　　
End Sub

Sub SampleC()
　　Dim i As Long
　　Dim j As Long
　　Dim x As Long
　　'元ブックと元シート
　　Dim dBK As Workbook
　　Dim dSh As Worksheet
　　'転記ブックと転記シート
　　Dim nBK As Workbook
　　Dim nSh As Worksheet
　　
　　Set dBK = ThisWorkbook
　　Set dSh = dBK.Sheets("Sheet3")
　　
　　'Just In Case
　　If Not ActiveSheet Is dSh Then
　　　　MsgBox dSh.Name & "をアクティブにしてから実行してください"
　　　　Exit Sub
　　End If
　　
　　Application.ScreenUpdating = False
　　
　　i = ActiveCell.Row　　　'抽出すべき行番号
　　Set nBK = Workbooks.Add(xlWBATWorksheet)
　　Set nSh = nBK.Sheets(1)
　　nSh.Name = "ﾃﾞｰﾀ抽出"
　　
　　j = 6
　　For x = 1 To 46 Step 5
　　　　nSh.Cells(j, "B").Resize(, 4).Value = dSh.Cells(i, x).Resize(, 4).Value
　　　　nSh.Cells(j, "H").Value = dSh.Cells(i, x + 4).Value
　　　　j = j + 5
　　Next
　　
End Sub

1 hits

▼

【76525】コードを短くしたい ゆーあ 14/12/26(金) 15:42