| |
コードを追加していったら、シートチェンジして並び替えをしているときの時間がかかるようになりました。
これは、コードの手直しで解決するものなのでしょうか？
シートは複数ありますが、一つ目のシートは名簿で、下記コードがあります。
問題は、シートチェンジした後ですので、このシートはこのままで良いのかと思っています。
' 名簿シートの該当行右クリック処理
'
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
'選択した名簿の氏名（Ｊ列）をシート施設のＦ２に入力する
With Sheets("施設")
.Range("F2").Value = Cells(Target.Row, "J").Value
End With
Sheets("施設").Select
End Sub
二つ目のシートは、利用施設一覧で、
５行目以降について、Ｅ列に施設名を新規入力した場合は、Ｄ列にカナを振り、Ｆ列に"なし"と振ること。
Ｆ２に表示されている者が、５行目以降について、G列からIV列までのセルに入力されている場合は、その行を上にすること。
利用施設の行の右端のセルに氏名を入力すること。
印刷用シートと記録簿シートに必要項目を入力すること。
このようなことが出来るようになっていて、確かに動いています。
ただ、二つ目のシートに移るとき、並べ替えに時間がかかっているようで、約３秒かかっています。
二つ目のシート「施設」 のコード
'５行目以降でＥ列に医療機関名を漢字で入力すると、Ｄ列に振り仮名を振り、Ｆ列に"なし"と入力する
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
'----- 医療機関のＧ列以降に利用者名をセット----
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 = "１"
.Offset(1, 4).Value = "受付印"
.Offset(1, 5).Value = "受付"
End With
Worksheets("印刷").PrintOut
'Worksheets("印刷").PrintPreview 'テスト用印刷プレビュー
End Sub
'-------------------------------------------------
初心者で大変申し訳ないのですが、これは、変更することでもっと処理速度が速くなるものなのでしょうか？
付け足ししすぎたでしょうか
よろしくお願いいたします。
|
|
マップー
- 07/2/7(水) 14:22 -
