Excel VBA質問箱 IV

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

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


6205 / 13644 ツリー ←次へ | 前へ→

【46584】コードをまとめることで、処理を早くできるでしょうか? マップー 07/2/7(水) 14:22 質問[未読]
【46593】Re:コードをまとめることで、処理を早くで... neptune 07/2/7(水) 16:54 発言[未読]
【46596】すみません、この部分だけお目通しいただけ... マップー 07/2/7(水) 17:15 質問[未読]
【46602】Re:すみません、この部分だけお目通しいた... ToShi 07/2/7(水) 20:16 発言[未読]
【46614】Re:すみません、この部分だけお目通しいた... マップー 07/2/8(木) 8:30 お礼[未読]
【46605】Re:すみません、この部分だけお目通しいた... neptune 07/2/7(水) 22:16 発言[未読]
【46615】ご指摘ありがとうございました。 マップー 07/2/8(木) 8:32 お礼[未読]

【46584】コードをまとめることで、処理を早くでき...
質問  マップー  - 07/2/7(水) 14:22 -

引用なし
パスワード
   コードを追加していったら、シートチェンジして並び替えをしているときの時間がかかるようになりました。

これは、コードの手直しで解決するものなのでしょうか?


シートは複数ありますが、一つ目のシートは名簿で、下記コードがあります。
問題は、シートチェンジした後ですので、このシートはこのままで良いのかと思っています。

'  名簿シートの該当行右クリック処理
'

Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)

If Target.Row < 2 Then Exit Sub

Cancel = True

With Sheets("印刷")
.Range("E15").Value = Cells(Target.Row, "G").Value
.Range("E16").Value = Cells(Target.Row, "H").Value
.Range("E17").Value = Cells(Target.Row, "I").Value
.Range("AA16").Value = Cells(Target.Row, "J").Value
.Range("AQ16").Value = Cells(Target.Row, "K").Value
.Range("AX16").Value = Cells(Target.Row, "L").Value
End With

'選択した名簿の氏名(J列)をシート施設のF2に入力する
With Sheets("施設")
.Range("F2").Value = Cells(Target.Row, "J").Value
End With

Sheets("施設").Select

End Sub


二つ目のシートは、利用施設一覧で、

5行目以降について、E列に施設名を新規入力した場合は、D列にカナを振り、F列に"なし"と振ること。

F2に表示されている者が、5行目以降について、G列からIV列までのセルに入力されている場合は、その行を上にすること。

利用施設の行の右端のセルに氏名を入力すること。

印刷用シートと記録簿シートに必要項目を入力すること。

このようなことが出来るようになっていて、確かに動いています。

ただ、二つ目のシートに移るとき、並べ替えに時間がかかっているようで、約3秒かかっています。


二つ目のシート「施設」 のコード

'5行目以降でE列に医療機関名を漢字で入力すると、D列に振り仮名を振り、F列に"なし"と入力する
Private Sub Worksheet_Change(ByVal Target As Range)
  Dim rng As Range
  Dim crng As Range
  Application.EnableEvents = False
  
LastRow = Range("E65536").End(xlUp).Row

For R = 5 To LastRow
  Set rng = Application.Intersect(Target, Range("E:E"))
  If Not rng Is Nothing Then
    For Each crng In rng
     With crng
       .Offset(0, -1).Value = _
        Evaluate("asc(phonetic(" & .Address & "))")
       End With
     Next
    End If
  If Target.Column = 5 Then
    Cells(Target.Row, "F") = "なし"
    End If
    Next R


  Application.EnableEvents = True
End Sub


'  シート医療機関がアクティブになった時の処理
Private Sub Worksheet_Activate()
Dim myRange As Range
Dim FindCell As Range
Dim LastRow As Long
Dim LastClm As Integer
Dim R As Long

If Range("F2").Value = "" Then Exit Sub

LastRow = Range("E65536").End(xlUp).Row

For R = 5 To LastRow
Set myRange = Range(Cells(R, "G"), Cells(R, "IV").End(xlToLeft))
If WorksheetFunction.CountIf(myRange, Range("F2").Value) > 0 Then
Cells(R, "B").Value = 0
Else
Cells(R, "B").Value = 1
End If
Next R

If WorksheetFunction.CountIf(Range("B5:B" & LastRow), 1) = 0 Then Exit Sub

LastClm = 5

For R = 5 To LastRow
If LastClm < Cells(R, "IV").End(xlToLeft).Column Then
LastClm = Cells(R, "IV").End(xlToLeft).Column
End If
Next R

Set myRange = Range("A5", Cells(LastRow, LastClm))

myRange.Sort Key1:=Range("B5"), Order1:=xlAscending, _
Key2:=Range("D5"), Order1:=xlAscending, _
Header:=xlGuess, OrderCustom:=1, MatchCase:=False
 Range("E5").Select

End Sub


'
'
'  シート医療機関の該当行を右クリックした時の処理
'
'

Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)

Dim Msg
Dim myRange As Range
Dim LastClm As Integer

If Target.Row < 4 Then Exit Sub

Cancel = True


'----- 医療機関のG列以降に利用者名をセット----

LastClm = Cells(Target.Row, "IV").End(xlToLeft).Column

Set myRange = Range(Cells(Target.Row, "G"), Cells(Target.Row, LastClm))

If WorksheetFunction.CountIf(myRange, Range("F2").Value) = 0 Then
Cells(Target.Row, LastClm + 1).Value = Range("F2").Value
LastClm = LastClm + 1
End If
'------------------------------------------


Sheets("印刷").Range("C10").Value = Cells(Target.Row, "E").Value

With Sheets("記録簿").Range("A65536").End(xlUp)
.Offset(1, 0).Value = Date
.Offset(1, 1).Value = Sheets("印刷").Range("C10").Value
.Offset(1, 2).Value = Sheets("印刷").Range("AA16").Value
.Offset(1, 3).Value = "1"
.Offset(1, 4).Value = "受付印"
.Offset(1, 5).Value = "受付"
End With

Worksheets("印刷").PrintOut

'Worksheets("印刷").PrintPreview 'テスト用印刷プレビュー

End Sub

'-------------------------------------------------


初心者で大変申し訳ないのですが、これは、変更することでもっと処理速度が速くなるものなのでしょうか?

付け足ししすぎたでしょうか
よろしくお願いいたします。

【46593】Re:コードをまとめることで、処理を早く...
発言  neptune  - 07/2/7(水) 16:54 -

引用なし
パスワード
   ▼マップー さん:
こんにちは
なんかResが付かないようなので。。。

長いので見る気はしませんけど、処理速度の改善をしようとする際、
一番最初にやることはどこが一番遅いかを見極めることです。

要所要所で処理時間を計ってみましょう。
timeで秒単位なら取得できます。
もっと精度がほしければtimegettime でググって見て下さい。
使い方のサンプルが山ほどありますから参考にして下さい。

【46596】すみません、この部分だけお目通しいただ...
質問  マップー  - 07/2/7(水) 17:15 -

引用なし
パスワード
   neptune さん ご回答ありがとうございます。

質問が長すぎて申し訳ありません。

処理に時間がかかるのは、並べ替えなのです。
ただ、これは必要なことだと思っています。

素人でスミマセンが、

Private Sub Worksheet_Change(ByVal Target As Range)
  と
Private Sub Worksheet_Activate()
  は

一つにまとめられるものでしょうか?
意味合いが違いますか?
まとめられないなら、すぐにあきらめます。


考えているのは、下記の部分だけでもまとめることは出来るものなのかということです。

スミマセンが、教えていただけますでしょうか?


'5行目以降でE列に医療機関名を漢字で入力すると、D列に振り仮名を振り、F列に"なし"と入力する
Private Sub Worksheet_Change(ByVal Target As Range)
  Dim rng As Range
  Dim crng As Range
  Application.EnableEvents = False
  
LastRow = Range("E65536").End(xlUp).Row

For R = 5 To LastRow
  Set rng = Application.Intersect(Target, Range("E:E"))
  If Not rng Is Nothing Then
    For Each crng In rng
     With crng
       .Offset(0, -1).Value = _
        Evaluate("asc(phonetic(" & .Address & "))")
       End With
     Next
    End If
  If Target.Column = 5 Then
    Cells(Target.Row, "F") = "なし"
    End If
    Next R
  Application.EnableEvents = True
End Sub


'  シート医療機関がアクティブになった時の処理
Private Sub Worksheet_Activate()
Dim myRange As Range
Dim FindCell As Range
Dim LastRow As Long
Dim LastClm As Integer
Dim R As Long

If Range("F2").Value = "" Then Exit Sub

LastRow = Range("E65536").End(xlUp).Row

For R = 5 To LastRow
Set myRange = Range(Cells(R, "G"), Cells(R, "IV").End(xlToLeft))
If WorksheetFunction.CountIf(myRange, Range("F2").Value) > 0 Then
Cells(R, "B").Value = 0
Else
Cells(R, "B").Value = 1
End If
Next R

If WorksheetFunction.CountIf(Range("B5:B" & LastRow), 1) = 0 Then Exit Sub

LastClm = 5

For R = 5 To LastRow
If LastClm < Cells(R, "IV").End(xlToLeft).Column Then
LastClm = Cells(R, "IV").End(xlToLeft).Column
End If
Next R

Set myRange = Range("A5", Cells(LastRow, LastClm))

myRange.Sort Key1:=Range("B5"), Order1:=xlAscending, _
Key2:=Range("D5"), Order1:=xlAscending, _
Header:=xlGuess, OrderCustom:=1, MatchCase:=False
 Range("E5").Select

End Sub

【46602】Re:すみません、この部分だけお目通しい...
発言  ToShi  - 07/2/7(水) 20:16 -

引用なし
パスワード
   ▼マップー さん:

>Private Sub Worksheet_Change(ByVal Target As Range)
>  と
>Private Sub Worksheet_Activate()
>  は
>
>一つにまとめられるものでしょうか?

用途が違いますから、纏められないでしょう。


>'5行目以降でE列に医療機関名を漢字で入力すると、D列に振り仮名を振り、F列に"なし"と入力する
>Private Sub Worksheet_Change(ByVal Target As Range)
>  Dim rng As Range
>  Dim crng As Range
>  Application.EnableEvents = False
>  
>LastRow = Range("E65536").End(xlUp).Row
>
>For R = 5 To LastRow
>  Set rng = Application.Intersect(Target, Range("E:E"))
>  If Not rng Is Nothing Then
>    For Each crng In rng
>     With crng
>       .Offset(0, -1).Value = _
>        Evaluate("asc(phonetic(" & .Address & "))")
>       End With
>     Next
>    End If
>  If Target.Column = 5 Then
>    Cells(Target.Row, "F") = "なし"
>    End If
>    Next R
>  Application.EnableEvents = True
>End Sub

上のコードだったら、一般のシート関数で作成しても良いのでは?
っと思いましたが。

下のコードでは何を目的に作成されているのか、これだけでは分かりませんが
シートがActivateされた時に動作するようにコードが書かれているのですから
用途が違のでしょう。

>
>
>'  シート医療機関がアクティブになった時の処理
>Private Sub Worksheet_Activate()
>Dim myRange As Range
>Dim FindCell As Range
>Dim LastRow As Long
>Dim LastClm As Integer
>Dim R As Long
>
>If Range("F2").Value = "" Then Exit Sub
>
>LastRow = Range("E65536").End(xlUp).Row
>
>For R = 5 To LastRow
>Set myRange = Range(Cells(R, "G"), Cells(R, "IV").End(xlToLeft))
>If WorksheetFunction.CountIf(myRange, Range("F2").Value) > 0 Then
>Cells(R, "B").Value = 0
>Else
>Cells(R, "B").Value = 1
>End If
>Next R
>
>If WorksheetFunction.CountIf(Range("B5:B" & LastRow), 1) = 0 Then Exit Sub
>
>LastClm = 5
>
>For R = 5 To LastRow
>If LastClm < Cells(R, "IV").End(xlToLeft).Column Then
>LastClm = Cells(R, "IV").End(xlToLeft).Column
>End If
>Next R
>
>Set myRange = Range("A5", Cells(LastRow, LastClm))
>
>myRange.Sort Key1:=Range("B5"), Order1:=xlAscending, _
>Key2:=Range("D5"), Order1:=xlAscending, _
>Header:=xlGuess, OrderCustom:=1, MatchCase:=False
> Range("E5").Select
>
>End Sub

【46605】Re:すみません、この部分だけお目通しい...
発言  neptune  - 07/2/7(水) 22:16 -

引用なし
パスワード
   ▼マップー さん:
>neptune さん ご回答ありがとうございます。
>
>質問が長すぎて申し訳ありません。
>
>処理に時間がかかるのは、並べ替えなのです。
>ただ、これは必要なことだと思っています。
>
>素人でスミマセンが、
>
>Private Sub Worksheet_Change(ByVal Target As Range)
>  と
>Private Sub Worksheet_Activate()
>  は
>
>一つにまとめられるものでしょうか?
>意味合いが違いますか?
処理内容が違うのでそれは無理です。

>処理に時間がかかるのは、並べ替えなのです。
データ件数が書かれてないし、どれくらいの時間が掛かるか書いてないで、
はっきりは言えませんが、ソート処理自体はそんなに時間はかかりません。
Excelの固有機能は結構速いです。

以下、気づいた点を書きます。
1.頻繁にセルにアクセスしているが、application.screenupdating=false
  を使用していない。・・・・時間の無駄
2.Worksheet_Changeの度に行う必要があるのか?ないのなら無駄
3.Worksheet_Activateの度に行う必要があるのか?ないのなら無駄

以上再検討をしてみてはどうでしょう?

【46614】Re:すみません、この部分だけお目通しい...
お礼  マップー  - 07/2/8(木) 8:30 -

引用なし
パスワード
   ToShi さん ご回答ありがとうございました。

すっきりしました。

ちょっと安心?です。

【46615】ご指摘ありがとうございました。
お礼  マップー  - 07/2/8(木) 8:32 -

引用なし
パスワード
   ▼neptune さん ご指摘ありがとうございます。


1.頻繁にセルにアクセスしているが、application.screenupdating=false
  を使用していない。・・・・時間の無駄
2.Worksheet_Changeの度に行う必要があるのか?ないのなら無駄
3.Worksheet_Activateの度に行う必要があるのか?ないのなら無駄

このご指摘を再検討をします。

助かります。

ありがとうございました。

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