Excel VBA質問箱 IV

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

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


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

1062 / 13645 ﾂﾘｰ

←次へ　｜　前へ→

▼

【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


	【76525】コードを短くしたい

ゆーあ - 14/12/26(金) 15:42 -


	引用なし

	パスワード

WinXP Excel2000

顧客情報のデータベースとして使用しているファイルがあり、
フォーム上で情報の登録/変更/削除を行っております。

フォーム上に表示されている情報を印刷する時、
印刷ボタン（フォーム上に印刷用コマンドボタンを配置）を押して、
フォーム自体（PrintFormを使用）を印刷しておりました。

しかし、PrintFormでは、印刷設定が出来ず、
また複数人が使用する為、不具合が生じておりましたので、
フォーム表示上の情報を、新規ブックに転記する方法に変更しました。

新規ブックへの転記コード自体は問題無く出来たのでですが、
転記する情報量が多い為か、単純にコードが長い為か、
（どちらもかも）作業完了までかなりの時間を有しております。

転記コードの流れとして、
1.新規ブック立上げ
2.新規ブックに罫線で表を作成
3.新規ブック表に各項目名を入力
4.データベースファイルから新規ブックへ転記
5.新規ブックのフォント等調整変更
をしております。

やっと本題ですが、
4.データベースファイルから新規ブックへの転記
のコードが、現状１つずつコピーして貼り付けるようになってますので、
そのコードを短くできないかと考えております。
下記に抜粋ですが、コードを示しますので。
アドバイス等頂ければ幸いです。宜しくお願い致します。

　　Windows(exiWB).Activate　　'ﾃﾞｰﾀﾍﾞｰｽﾌｧｲﾙ選択
　　Worksheets("Sheet3").Activate　
　　Sheets("Sheet3").Cells(ActiveCell.Row, 1).Select
　　Selection.Copy
　　Windows(NewWB).Activate　　'新規ﾌﾞｯｸ選択
　　Sheets("ﾃﾞｰﾀ抽出").Range("B6").Select
　　Selection.PasteSpecial Paste:=xlValues
　　　　　　　　　　・
　　　　　　　　　　・
　　　　　　　　　　・
　　　　　　　　　　・
　　Windows(exiWB).Activate
　　Worksheets("Sheet3").Activate
　　Sheets("Sheet3").Cells(ActiveCell.Row, 50).Select
　　Selection.Copy
　　Windows(NewWB).Activate
　　Sheets("ﾃﾞｰﾀ抽出").Range("H51").Select
　　Selection.PasteSpecial Paste:=xlValues

データベースファイルのセルセレクトは、順番（1～50）ですが、
新規ブックの方は、規則性はあるもののランダムになってます。
　B6/C6/D6/E6/H6,B11/C11/D11/E11/H11,B16/C16/D16/E16/H16
　B21/C21/D21/E21/H21,B26/C26/D26/E26/H26,B31/C31/D31/E31/H31
　B36/C36/D36/E36/H36,B41/C41/D41/E41/H41,B46/C46/D46/E46/H46
　B51/C51/D51/E51/H51


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

β - 14/12/26(金) 17:54 -


	引用なし

	パスワード

▼ゆーあさん：

コードはよく読んでいませんが、１項目ごとに

・元ブックをActiveにして
・そこの項目をコピーして
・新ブックをアクティブにして
・書き込みセルを選択して
・ペースト

これでは時間がかかるでしょうね。

>データベースファイルのセルセレクトは、順番（1～50）ですが、
>新規ブックの方は、規則性はあるもののランダムになってます。

これについても、整理してコードを短くすることができますが、その前に
まずは、上記の状態を改善するところから始められてはいかがでしょう。

Sub Sample()
　　Dim dBK As Workbook
　　Dim nBK As Workbook
　　Dim dSh As Worksheet
　　Dim nSh As Worksheet
　　
　　Set dBK = Workbooks("●●●●.xls")
　　Set dSh = dBK.Sheets("Sheet3")
　　Set nBK = Workbooks("□□□□.xls")
　　Set nSh = nBK.Sheets("ﾃﾞｰﾀ抽出")
　　
　　Application.ScreenUpdating = False　　　'セル書き込みに伴う画面再描画の抑止（処理時間の短縮化）
　　
　　nSh.Range("B6").Value = dSh.Range("A1").Value
　　nSh.Range("C6").Value = dSh.Range("A2").Value
　　nSh.Range("D6").Value = dSh.Range("A3").Value
　　
　　　　　　'
　　　　　　'
　　　　　　'
　　　　　　
End Sub


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

ゆーあ - 14/12/26(金) 21:10 -


	引用なし

	パスワード

▼β さん：

コメントありがとうございます。
ご説明不足で大変申し訳ございませんが、
現状、データベースのブックと新規ブックを下記の用に宣言しており、
流用しようとしましたが、私の力量では無理でした。。。

Dim exiWB As String
Dim NewWB As String
Dim A As Workbook
Dim C As Workbook

Set A = ThisWorkbook
exiWB = ThisWorkbook.Name
Set C = Workbooks.Add(Template:=xlWBATWorksheet)
NewWB = ActiveWorkbook.Name
ActiveWorkbook.Sheets("Sheet1").Name = "ﾃﾞｰﾀ抽出"


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

β - 14/12/26(金) 22:33 -


	引用なし

	パスワード

▼ゆーあさん：

それでは、先ほどアップしたSaampleに、追加で書いてもらったコード要件を
カミして再掲。ただし、転記コードは３行しか書いてません。残りの４７行は
そちらで追加して完成させてください。

で、これでもいいと思いますが、【コードを整理して短く】した　Sample2 も
あわせてアップいます。コードも短くしていますが、５セル１セットの転記、
Sampleのほうではコードも５行（つまりセルに５回書き込み）あるのですが
Sample2では２行（つまりせるにへの書き込み回数は１セット２回）にしています。

まず、Sample を自分のものとして理解したのちに Sample2　に取り組んでください。

Sub Sample()
　　'元ブックと元シート
　　Dim dBK As Workbook
　　Dim dSh As Worksheet
　　'転記ブックと転記シート
　　Dim nBK As Workbook
　　Dim nSh As Worksheet
　　
　　Set dBK = ThisWorkbook
　　Set dSh = dBK.Sheets("Sheet3")
　　
　　Set nBK = Workbooks.Add(xlWBATWorksheet)
　　Set nSh = nBK.Sheets(1)
　　nSh.Name = "ﾃﾞｰﾀ抽出"
　　
　　Application.ScreenUpdating = False　　　'セル書き込みに伴う画面再描画の抑止（処理時間の短縮化）
　　
　　nSh.Range("B6").Value = dSh.Range("A1").Value
　　nSh.Range("C6").Value = dSh.Range("A2").Value
　　nSh.Range("D6").Value = dSh.Range("A3").Value
　　
　　　　　　'
　　　　　　'省略　ゆーあさんのほうで、コードを追加して完成させてください
　　　　　　'
　　　　　　
End Sub

Sub Sample2()
　　Dim i As Long
　　Dim j 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")
　　
　　Set nBK = Workbooks.Add(xlWBATWorksheet)
　　Set nSh = nBK.Sheets(1)
　　nSh.Name = "ﾃﾞｰﾀ抽出"
　　
　　Application.ScreenUpdating = False
　　
　　j = 6
　　For i = 1 To 46 Step 5
　　　　nSh.Cells(j, "B").Resize(, 4).Value = WorksheetFunction.Transpose(dSh.Cells(i, "A").Resize(4).Value)
　　　　nSh.Cells(j, "H").Value = dSh.Cells(i + 4, "A").Value
　　　　j = j + 5
　　Next
　　
End Sub


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

β - 14/12/26(金) 22:38 -


	引用なし

	パスワード

▼ゆーあさん：

追伸です。
xl2000の環境がないので、
Set nBK = Workbooks.Add(xlWBATWorksheet)
ここがちょっと不安です。（Add と Set を同時にできたかどうか）
不具合があればAddとSetをわけますので連絡願います。


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

ゆーあ - 14/12/27(土) 11:37 -


	引用なし

	パスワード

▼β さん：

こんにちはです。
コード作成頂き、誠にありがとうございます。

早速、Sampleの方を試してみました。
元ブックのActiveCellを読んでくる必要がある為、
コードを、
　　nSh.Range("B6").Value = dSh.Cells(ActiveCell.Row, 1).Value
に変更しましたが、上手く動作しませんでした。。。

データベースとして使用している元ブックは、
各データを行で一つのグループとして分けており、
フォーム上の↓↑で、行を移動させ、フォーム上に表示させております。
したがって、元ブックのActiveCellがある行のデータを新規ブックに
転記させようと思ったのですが、変更したコードでは駄目でした。

どのように変更（取得）してやればよいのでしょうか？


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

β - 14/12/27(土) 12:34 -


	引用なし

	パスワード

▼ゆーあさん：

最初に提示いただいたコードを良く読んでいませんでした。
私がアップしたコードでは、、元ブックからの抽出がA1,A2,A3,A4・・・
としていましたが、そうじゃなかったんですね。

実行時に選択されていたセルの行の　A●,B●,C●,D●,・・・・
なんですね。

この理解が正しければ、修正したSampleとSample2を再掲しますので
確認願います。


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

ゆーあ - 14/12/27(土) 13:35 -


	引用なし

	パスワード

▼β さん：

コメントありがとうございます。
またまた私の説明不足で申し訳ございません。
最初にもっと分かりやすく説明するべきでした。。。

ですがお陰様で、
ご提示頂いたコードを調べることで勉強にはなってますので、
大変感謝しております。

理解の正否については、仰る通り、
実行時に選択されていたセル行ご認識で問題ございません。
お手数お掛けして申し訳ございませんが、宜しくお願い致します。


	【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


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

ゆーあ - 14/12/27(土) 17:57 -


	引用なし

	パスワード

▼β さん：

コメントありがとうございます。
ちょっと（かなり）こんがらがってきました。。。

今バタバタしておりますので、
来週頭に改めて返信させて頂きます。すみません。。。


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

ゆーあ - 14/12/29(月) 11:07 -


	引用なし

	パスワード

▼β さん：

おはようございます。
返信遅くなり、申し訳御座いません。

早速ですが、
まず、
>ActiveCell や Selection や ActiveSheet や ActiveWorkbook を前提にした
>コードは極力避けることが推奨されます。
>ActiveSheetが本来のものとは異なっていたり、そんなことが往々にして発生し、
>とんでもない障害になる可能性があります。
とのことですが、
　　　Sheets("Sheet3").Cells(ActiveCell.Row, 1).Select
のことを仰ってるでしょうか？
その場合、別件ですがご相談させて頂きたいです。。。

先日、データベースとして使用している元ブックは、
各データを行で一つのグループに分けていると説明したと思いますが、
元ブックのSheet構成として、
　Sheet1:フォーム呼出ボタンのみ(sheet表示）
　Sheet2：個人データ登録用シート(非表示）
　Sheet3:（各個人データ）データシート1（非表示）
　Sheet4:（各個人データ）データシート2（非表示）
としており、
操作（登録/更新/削除）は全て、フォーム(個人データ）上で行っております。
フォーム（個人データ）上に、データシート1&2フォーム呼出のコマンドボタンを
設置しており、
フォーム（個人データ）より別フォームを立ち上げて、データを登録
する様にしております。

Sheet2
　　Ａ　　B　 C　　　D　　・・・
1　名前年齢住所電話番号　・・・
2　田中　30　・・・
3　佐藤　40　・・・
4　小林　50　・・・

Sheet3
　　Ａ　　 B　　C　　　D　　 E　　 F　　 G　　H　　
1　依頼日1 受付1 対応1 内容1 依頼2 受付2 対応2 内容2・・・
2　 1/1　　山田　・・・
3　 2/1　　富樫　・・・
4　 3/1　　葉山　・・・

Sheet4
　　Ａ　　　B　　　 C　　　D　　　E　　　F　　　G　　 H　　
1　依頼日51 受付51 対応51 内容51 依頼52 受付52 対応52 内容52・・・
2　 5/1　　富樫　・・・
3　 6/1　　葉山　・・・
4　 7/1　　山田　・・・

Sheet3の連番でSheet4に続きます。
どのSheetも2行目は、田中のデータとなり、3行目は、佐藤のデータとなります。

やっと本題ですが、
Sheet2の氏名位置を基に、各シートのデータ管理を行っているのですが、

　　Dim 氏名 As Range
　　Dim AAA As String
　　Set 氏名 = Worksheets("Sheet2").Cells(ActiveCell.Row, 1)
　　AAA = 氏名.Address(False, False)

頻繁に、ActiveCellなど使用してますので、
現状の管理方法では、とんでもない障害が起こりえるでしょうか？？

次に、ご提示頂いたコードについてですが、
SampleAで動作確認したところ、
"Sheet3をアクティブにしてから実行して下さい"
と言われてしまいました。
アクティブになるように試してみましたが、ダメでした。

よってSampleBでも同様の現象が起こると思ったので、
SampleBを使って、
　　Windows(exiWB).Activate
　　Worksheets("Sheet3").Activate
　　Sheets("Sheet3").Cells(ActiveCell.Row, 1).Resize(, 4).Select
　　Selection.Copy
　　Windows(NewWB).Activate
　　Sheets("データ抽出").Range("B6").Resize(, 4).Select
　　Selection.PasteSpecial Paste:=xlValues
　　
　　Windows(exiWB).Activate
　　Worksheets("Sheet3").Activate
　　Sheets("Sheet3").Cells(ActiveCell.Row, 5).Select
　　Selection.Copy
　　Windows(NewWB).Activate
　　Sheets("データ抽出").Range("H6").Select
　　Selection.PasteSpecial Paste:=xlValues

に改良してみました、
C～E列の記載が無くなった分、早くなった気がしますがどうでしょうか？
宜しくお願い致します。


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

ゆーあ - 14/12/29(月) 11:30 -


	引用なし

	パスワード

▼β さん：

SampleCを使っての改良もしてみました。
もっと早くなった気がします！！

　　j = 6
　　For x = 1 To 46 Step 5
　　Windows(exiWB).Activate
　　Worksheets("Sheet3").Activate
　　Sheets("Sheet3").Cells(ActiveCell.Row, x).Resize(, 4).Select
　　Selection.Copy
　　Windows(NewWB).Activate
　　Sheets("データ抽出").Range("B" & j).Resize(, 4).Select
　　Selection.PasteSpecial Paste:=xlValues
　　Windows(exiWB).Activate
　　Worksheets("Sheet3").Activate
　　Sheets("Sheet3").Cells(ActiveCell.Row, x + 4).Select
　　Selection.Copy
　　Windows(NewWB).Activate
　　Sheets("データ抽出").Range("H" & j).Select
　　Selection.PasteSpecial Paste:=xlValues
　　j = j + 5
　　Next


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

γ - 14/12/29(月) 12:03 -


	引用なし

	パスワード

横から失礼します。# 殆ど同じ指摘かもしれませんが、あえて。

Sheetを逐一アクティブにしたり、Selectを頻繁に行うのは、
速度的な効率が悪い上に、コードの可読性（判りやすさ、簡潔性）を
損ないます。実は後者のほうがより重要かなと考えています。

また、
・Bookがアクティブでなければ、Sheetが選択できない（エラーになる）
・Sheetがアクティブでなければ、セルを選択できない（エラーになる）と
いったことに注意を払わなければならりません。
さらに、単にActiveCellと書くと、別のシートのそれを誤って引用する懼れもあります。
一度、対応するSheetを確認したうえで、Range変数にセットして、
その変数を使い回すほうがよいでしょう。

今は表面上問題化しなくても、リスクを抱えた書き方ではないかと思います。
できるだけこれらに依存しない書き方を採用するのがよいでしょうし、
皆さん、そうされていますよ。（日本人にはこういう言い方が有効らしいです。）

[無駄なSelectをしない]
ht tp://officetanaka.net/excel/vba/speed/s2.htm
などを参考にして下さい。


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

ゆーあ - 14/12/29(月) 13:19 -


	引用なし

	パスワード

▼γ さん：

コメントありがとうごいます。
仰っておられるのは、
　　Windows(exiWB).Activate
　　Worksheets("Sheet3").Activate
　　Sheets("Sheet3").Cells(ActiveCell.Row, x).Resize(, 4).Select
　　Selection.Copy
ですよね？
私も逐一アクティブにしたり、セレクトしたくないので、
短くしようとしたのですが、ことごとく失敗してます。。。

たとえば、
　　　　Worksheets("Sheet3").Activate
を抜いてみたりもしたのですが、抜くと上手く動作しないんです。

申し訳御座いませんが、具体的に
>一度、対応するSheetを確認したうえで、Range変数にセットして、
>その変数を使い回すほうがよいでしょう。
とはどのように記述したら良いのでしょうか？
私もリスクを抱えた書き方では無い方法が良いと思いますので、
お手数お掛け致しますが、お教え頂ければ幸いで御座います。


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

β - 14/12/29(月) 15:08 -


	引用なし

	パスワード

▼ゆーあさん：

γさんから、貴重なアドバイスがでています。
紹介されたOfficeTANAKAサイトの記載もよく読んでみてください。

私も、具体的なテーマからちょっと離れて。

「SampleBを使って・・・改良してみました。」
「SampleCを使っての改良もしてみました。」

と書いておられますが、実際に示していただいた「改良コード」は
もともとの、ゆーあさんのコーディングスタイルのままです。
ゆーあさんのコードは値の転記を、Copy-->PasteSpecial(xlValue)　で行っていましたね。
それを実現するためにSheetのSelectや、セルのSelectも記述してあったわけです。

で、SampleA は、それを、

転記先セル.Value = 転記元セル.Value

という、ある意味、VBAスタンダードの記述方式に変えたものです。

次に、SampleB は　１項目ごとの転記（つまり転記すべきセル数だけ、転記コードが必要）
から、「連続した領域」を一挙に転記（コードは１行ですみます）するために

転記先セル【群】.Value = 転記元セル【群】.Value

に変更して、コード数を少なくし、コード数が少ないということは、実行回数も少ないので
処理効率のアップも図ったものです。

最後に、SampleC は、短くなったとはいえ、SampleB で、同じような規則性で処理されている
部分を変数を使ったループ処理として記述。コード数を減少させえています。

別のポイントで。

VBAでセルを特定する場合、「このブック」の「このシート」の「このセル」と書きます。
「このブック」が省略されれば、今アクティブなブックというようになります。
「このシート」が省略されれば、今アクティブなシートとみなされます。
（いずれも標準モジュールでの話ですが）
なので、ゆーあさんは「このセル」という表現だけで処理ができるように
処理対象のブックをアクティブにし、処理対象のシートをアクティブにしているわけですね。

でも、私が提示したコードでは、ブックのアクティブもシートのアクティブも行っていない。
だけど、処理はできたはずです。そこのところを、じっくりと考えてみてください。

あるセルの値を、別シートのセルに転記する操作をマクロ記録しますと

Sub Macro1()
　　Sheets("Sheet1").Select
　　Range("A1").Select
　　Selection.Copy
　　Sheets("Sheet3").Select
　　Range("E9").Select
　　Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
　　　　:=False, Transpose:=False
End Sub

こんなコードが生成されますね。

で、これと同じことをしようと以下のコードを書いたとします。

Sub TestNG1()
　　Range("A1").Select
　　Selection.Copy
　　Range("E9").Select
　　Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
　　　　:=False, Transpose:=False
End Sub

シートのSelectをなくしたものでエス。
でも、これでは最初のA1がどこのシートのA1なのか、ちょっと心細い記述ですね。
何よりも、E9　は、A1と同じシートになってしまいますね。具合悪いですね。

ということで

Sub TestNG2()
　　Sheets("Sheet1").Range("A1").Select　　 '★シートを特定
　　Selection.Copy
　　Sheets("Sheet3").Range("E9").Select　　 '★でも、ここでエラー
　　Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
　　　　:=False, Transpose:=False
End Sub

こんなように、セルがどのシートなのかを特定しました。
でも、E9 の Select でエラーになります。
セル.Select は、そのセルがアクティブシートにある場合のみOKで、そうでなければエラー。

なんとかしたいということで

Sub TestOK1()　'★シートとセルを特定してコピーペースト
　　Sheets("Sheet1").Range("A1").Copy
　　Sheets("Sheet3").Range("E9").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
　　　　:=False, Transpose:=False
End Sub

あぁ、これでうまくいきました。
でも、Copy->PasteSpecialですから２２のコードが必要ですね。

Sub TestOK2()
　　Sheets("Sheet1").Range("A1").Copy Sheets("Sheet3").Range("E9")
End Sub

あぁ、これで１行でできました。
でも、仮にA1に書式設定があればあそれごとコピーされます。値の転記であれば

Sub TestOK3()
　　Sheets("Sheet3").Range("E9").Value = Sheets("Sheet1").Range("A1").Value
End Sub

一般にはこのように書くわけです。

消化不良になるかも？なので、これぐらいでやめます。
ここでコメントしたことを念頭に、もう一度、SampleA,SampleB,SampleC を眺めてください。


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

γ - 14/12/29(月) 15:18 -


	引用なし

	パスワード

> 　　Dim 氏名 As Range
> 　　Dim AAA As String
> 　　Set 氏名 = Worksheets("Sheet2").Cells(ActiveCell.Row, 1)
> 　　AAA = 氏名.Address(False, False)
>
> 頻繁に、ActiveCellなど使用してますので、
>　現状の管理方法では、とんでもない障害が起こりえるでしょうか？？
すべての発言を読んでいるわけではないのですが、
上記のコードをみて　ActiveCellの属するシートが心配になったのでした。

ところで、
> 　　Windows(exiWB).Activate
> 　　Worksheets("Sheet3").Activate
> 　　Sheets("Sheet3").Cells(ActiveCell.Row, 1).Resize(, 4).Select
> 　　Selection.Copy
> 　　Windows(NewWB).Activate
> 　　Sheets("データ抽出").Range("B6").Resize(, 4).Select
> 　　Selection.PasteSpecial Paste:=xlValues
> 　　
>　　　Windows(exiWB).Activate
> 　　Worksheets("Sheet3").Activate
> 　　Sheets("Sheet3").Cells(ActiveCell.Row, 5).Select
> 　　Selection.Copy
> 　　Windows(NewWB).Activate
> 　　Sheets("データ抽出").Range("H6").Select
> 　　Selection.PasteSpecial Paste:=xlValues
は、例えば以下のように書けるでしょう。

　　Dim sWs As Worksheet
　　Dim dWs As Worksheet
　　Dim r As Long

　　Windows(exiWB).Activate
　　Worksheets("Sheet3").Activate
　　r = ActiveCell.Row

　　Set sWs = Workbooks(exiWB).Sheets("Sheet3")
　　Set dWs = Workbooks(NewWB).Sheets("データ抽出")

　　sWs.Cells(r, 1).Resize(, 4).Copy
　　dWs.Range("B6").Resize(, 4).PasteSpecial Paste:=xlValues

　　sWs.Cells(r, 5).Copy
　　dWs.Range("H6").PasteSpecial Paste:=xlValues
　　・・・以下略・・・

こんな感じです。
何度も ActiveCellと連呼せずに、一度定義した r を使い回すと、
逆にそれが変動しているかどうか心配する必要がありません。

これをもっと簡略化したのが、
βさんの　,Valueプロパティに直接書き込む方式です。
すでに、βさんのものがありますから、それを参考にしてください。

# 文章作成後に　βさんの投稿があることを知りました。
# たぶん重複しているかと思いますが、あえて追記しておきます。


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

ゆーあ - 14/12/29(月) 18:19 -


	引用なし

	パスワード

▼β さん：
　γさん

ご指導頂きありがとうございます。
また勝手なことばかりして、すみません。。。

SampleAを実行すると、
「Sheet3をアクティブにして下さい」
と動作ストップするので、
アクティブにするには？と考えていろいろ試してたのですが、
上手くアクティブにならず、私のなかで唯一アクティブになるコードが、
　　Windows(exiWB).Activate
　　Worksheets("Sheet3").Activate
でしたので、元のコードに戻った次第でした。。。

っで再度SampleAを眺めてみました。
流れは解る(なんとなくですが)のですが、
やはり実行すると何故か「アクティブにして下さい」と言われます。。。
それで、この文を、
　　If Not ActiveSheet Is dSh Then
　　　　MsgBox dSh.Name & "をアクティブにしてから実行してください"
　　　　Exit Sub
　　End If
消してみました。
すると、ちゃんと動作を行いました。

ここで、元ブックのSheet3をアクティブにしてるから実行するというのは、
なぜ必要なのでしょうか？


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

β - 14/12/29(月) 19:41 -


	引用なし

	パスワード

▼ゆーあさん：

「Sheet3をアクティブにして下さい」
このメッセージは、エクセルやVBAではなく、このマクロで出しています。
決して、プログラムを直してくださいというメッセージではないんです。

マクロ処理を開始する時点でのデータシート(Sheet3) で選ばれているセルの行
のデータを転記先シートに転記しますよね。
ですから、どこが選ばれているかを把握しなきゃいけないんですが、このセル
（ActiveCell) を参照しようとした場合、必ずこのシートがアクティブになっている
必要があります。

想定としては、データシートをゆーあさんがアクティブにして、目的の行を選んで
マクロ実行。
こう考えているんですが、このメッセージがでたということは、実行時には
別のシートがアクティブになっているということになります。

それとも、データシート（Sheet3)　がアクティブな状態（前面にでている状態）で
このメッセージがでたあということでしょうか？

もしかして・・・・
ゆーあさんの操作手順として、
・データシート（Sheet3)のコピーすべき行のセルを選ぶ
・それから、別のシートを選んで、なにかする
・で、この状態で（別のシートが表示されている状態で）マクロ実行
・マクロは、前に、データシート上で選択してあったセルの行のデータをコピーする。

もし、こういった流れがいいのなら、SampleA,B,Cともに

　　'Just In Case
　　If Not ActiveSheet Is dSh Then
　　　　MsgBox dSh.Name & "をアクティブにしてから実行してください"
　　　　Exit Sub
　　End If

これを消して

Application.ScreenUpdating = False　の下に

dSh.Select

を追加。

これでいけますけど・・・・

でも、自分だったら、ちゃんと、選んだ行を目で確認しながら実行しますけど。
さっき、ちゃんと正しい行を選んでいたかどうか、不安じゃないですか？


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

ゆーあ - 14/12/30(火) 9:00 -


	引用なし

	パスワード

▼β さん：

おはようございます。
コメントありがとうございます。

「Sheet3をアクティブにして下さい」となる、理由が分かりました！
元ブックの方が、
　Sheet1:フォーム呼出ボタンのみ(sheet表示）
　Sheet2：個人データ登録用シート(非表示）
　Sheet3:（各個人データ）データシート1（非表示）
　Sheet4:（各個人データ）データシート2（非表示）
としており、
フォーム帖の全ての操作の後、
唯一表示しているSheet1をアクティブになるようにしていた為、
Sheet3をアクティブにして下さいと出ておりました。。。

正しい行を選んだか確かに心配です。
少し操作を考えてみます。。。

しかし、お陰様で、
最初より大幅にコードが短くなり、
処理時間も短縮となりました。
望み通りの方向に導いて下さり、本当にありがとうございました。

お教え頂いたことを、もう一度良く読み返し実践し、
自分の力に変えれる様に頑張ります！
ありがとうございました！！


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

1062 / 13645 ﾂﾘｰ

←次へ　｜　前へ→

ページ：

┃

記事番号：

(SS)C-BOARD v3.8 is Free