Excel VBA質問箱 IV

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

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


5806 / 76732 ←次へ | 前へ→

【76533】Re:コードを短くしたい
発言  β  - 14/12/27(土) 16:22 -

引用なし
パスワード
   ▼ゆーあ さん:

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

その前に、

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

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

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

前置きは以上。

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

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

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

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

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 発言[未読]
【76526】Re:コードを短くしたい β 14/12/26(金) 17:54 発言[未読]
【76527】Re:コードを短くしたい ゆーあ 14/12/26(金) 21:10 発言[未読]
【76528】Re:コードを短くしたい β 14/12/26(金) 22:33 発言[未読]
【76529】Re:コードを短くしたい β 14/12/26(金) 22:38 発言[未読]
【76530】Re:コードを短くしたい ゆーあ 14/12/27(土) 11:37 発言[未読]
【76531】Re:コードを短くしたい β 14/12/27(土) 12:34 発言[未読]
【76532】Re:コードを短くしたい ゆーあ 14/12/27(土) 13:35 発言[未読]
【76533】Re:コードを短くしたい β 14/12/27(土) 16:22 発言[未読]
【76534】Re:コードを短くしたい ゆーあ 14/12/27(土) 17:57 発言[未読]
【76535】Re:コードを短くしたい ゆーあ 14/12/29(月) 11:07 発言[未読]
【76536】Re:コードを短くしたい ゆーあ 14/12/29(月) 11:30 発言[未読]
【76537】Re:コードを短くしたい γ 14/12/29(月) 12:03 発言[未読]
【76538】Re:コードを短くしたい ゆーあ 14/12/29(月) 13:19 発言[未読]
【76539】Re:コードを短くしたい β 14/12/29(月) 15:08 発言[未読]
【76541】Re:コードを短くしたい ゆーあ 14/12/29(月) 18:19 発言[未読]
【76542】Re:コードを短くしたい β 14/12/29(月) 19:41 発言[未読]
【76543】Re:コードを短くしたい ゆーあ 14/12/30(火) 9:00 お礼[未読]
【76540】Re:コードを短くしたい γ 14/12/29(月) 15:18 発言[未読]

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