EXCEL VBA エラーの意味が分からず
いつも、お世話になっております。
下記コードで、レコード１と２を前へと次へを繰り返し何度か操作すると、エラーになってしまいます。なぜエラーになって、どう修正すれば回避できるのかが分かりません。
どうかご教授いただけないでしょうか。よろしくお願いいたします。
エラーの状況
inputシートで、maeとtsugiの動作を何度か行うと、「If pict.TopLeftCell.Address = targetRange.Address Then」の部分が黄色く塗りつぶされ、「実行時エラー1004 アプリケーション定義またはオブジェクト定義のエラーです。」と表示されてしまします。たぶん写真の削除の時にエラーになっているのだと思いますが、
'■標準モジュールのコード。dataシートのレコードを移動し、inputシートのBC1セルに表示する。
Public trg As Range
Sub Saisyo()
Set trg = Worksheets("data").Range("A1")
Do
Set trg = trg.Offset(1, 0)
Loop Until trg.EntireRow.Hidden = False
Call Tenki
End Sub
Sub Saigo()
Set trg = Worksheets("data").Range("A60000").End(xlUp)
Call Tenki
End Sub
Sub Mae()
On Error GoTo errhandle
If trg.row >= 3 Then
Do
Set trg = trg.Offset(-1, 0)
Loop Until trg.EntireRow.Hidden = False
If trg.row = 1 Then
MsgBox "これより前のレコードはありません"
Call Saisyo
Exit Sub
Else
Call Tenki
End If
Else
MsgBox "これより前のレコードはありません!"
End If
Exit Sub
errhandle:
Call Saisyo
End Sub
Sub Tsugi()
On Error GoTo errhandle
If trg.row < Worksheets("data").Range("A60000").End(xlUp).row Then
Do
Set trg = trg.Offset(1, 0)
Loop Until trg.EntireRow.Hidden = False
Call Tenki
Else
MsgBox "これより後ろのレコードはありません"
End If
Exit Sub
errhandle:
Call Saigo
End Sub
Sub Tenki()
Worksheets("input").Range("BC1").Value = trg.Offset(0, 0)
End Sub
'■sheet 1のモジュール。inputシートBC1セルの値を見て、dataシートへ値を読みにいき、inputシートへ表示する。
Private Sub hyouji()
Dim fRange As Range
Dim kensaku As Long
Set fRange = Sheets("data").Columns(1).Find(What:=Range("BC1").Value, _
LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows)
If (fRange Is Nothing) Then '見つからなかった？
MsgBox "入力された顧客コードが存在しません。", vbExclamation
Exit Sub
End If
kensaku = fRange.row '検索された顧客DCの行位置を求める
Range("BC1:BE1").Value = Sheets("data").Cells(kensaku, 1).Value '整理No
Range("AX1").Value = Sheets("data").Cells(kensaku, 2).Value '固有ID
Range("I4").Value = Sheets("data").Cells(kensaku, 3).Value '工場名
Range("P4").Value = Sheets("data").Cells(kensaku, 4).Value '柱No
Range("W4").Value = Sheets("data").Cells(kensaku, 5).Value '盤No
Range("I5").Value = Sheets("data").Cells(kensaku, 6).Value '変台系統1
Range("S5").Value = Sheets("data").Cells(kensaku, 7).Value '変台系統2
Range("I6").Value = Sheets("data").Cells(kensaku, 8).Value '分電盤設置時期
Range("B8").Value = Sheets("data").Cells(kensaku, 9).Value '主な供給先
Range("B14").Value = Sheets("data").Cells(kensaku, 10).Value '特記
Range("AD4").Value = Sheets("data").Cells(kensaku, 11).Value '盤位置の目安
Range("AT8").Value = Sheets("data").Cells(kensaku, 12).Value '幹線線相
Range("R36").Value = Sheets("data").Cells(kensaku, 13).Value '盤写真ファイル名
Range("AT36").Value = Sheets("data").Cells(kensaku, 14).Value '単結図ファイル名
End Sub
'■sheet 1のモジュール。"$R$36"と"$AT$36"の写真ファイル名を見て、"C37"と"AE37"セルに表示させる。
Private Sub Worksheet_Change(ByVal Target As Range)
Dim fRange As Range
Dim touroku As Long
Select Case Target.Address
Case "$BC$1"
Call hyouji
Case "$R$36"
myLoadPicture "board_Image", Target.Text, Range("C37")
Case "$AT$36"
myLoadPicture "map_Image", Target.Text, Range("AE37")
Case "$AT$8"
Call red_circle
Case Else
Exit Sub
End Select
End Sub
Private Sub myLoadPicture(folderName As String, fname As String, targetRange As Range)
Dim pict As Shape, picPath As String
picPath = ThisWorkbook.Path & "\" & folderName & "\" & fname
If fname = "" Then
picPath = ThisWorkbook.Path & "\" & folderName & "\" & "NoImage.jpg"
End If
With ActiveSheet
For Each pict In .Shapes
If pict.TopLeftCell.Address = targetRange.Address Then
pict.Delete
Exit For
End If
Next pict
Set pict = .Shapes.AddPicture(picPath, msoTrue, msoFalse, _
targetRange.Left, targetRange.Top, 300, 360)
End With
End Sub
お礼
回答ありがとうございました。 パスの指定と言われて気づきました。 ファイルオープン時のコードで、ThisWorkbook.Path の指定を忘れていたようです。