|
▼ゆーあ さん:
それでは、コードを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
|
|