![](/img/trans.png)
[英]VBA EXCEL Run time error 1004 Method 'Range of Object_worksheet' failed
[英]Method Range of object_worksheet failed 1004
我編寫了一些代碼,這些代碼在調試時可以很好地工作。 但是,當我刪除斷點並僅運行代碼時,它會給出運行時錯誤:
運行時錯誤'1004'方法范圍object_worksheet失敗。
它指的是下一行:
Set copyrange = sh.Range("A" & i & ":E" & i & ",I" & i & ":O" & i & ",Q" & i & ",V" & i) 'name column in sheet = Q
但是在調試時,沒有問題。 也許緩存已滿?
Private Sub btnGetDevices_Click()
'open every sheet after summary
'copy columns A,B,C,D,E,I,J,K,L,M,N,O, Q,V to summary
Dim sh As Worksheet
Dim copyrange As Range
Application.ScreenUpdating = False
Sheets("Summary").Rows(4 & ":" & Sheets("Summary").Rows.Count).Delete
For Each sh In ActiveWorkbook.Worksheets
If sh.Name <> "Database" And sh.Name <> "Template" And sh.Name <> "Help" And sh.Name <> "OVERVIEW" And sh.Name <> "Develop" And sh.Name <> "Schedule" And sh.Name <> "Information" And sh.Name <> "Announcements" And sh.Name <> "Summary" Then
sh.Select
LastRow = ActiveSheet.Range("L1048555").End(xlUp).Row
For i = 14 To LastRow
If sh.Range("Q" & i).Value <> Empty And sh.Range("N" & i).Value <> "Designer" And sh.Range("O" & i).Value <> "Layouter" Then
Set copyrange = sh.Range("A" & i & ":E" & i & ",I" & i & ":O" & i & ",Q" & i & ",V" & i) 'name column in sheet = Q
NameDevice = sh.Range("Q" & i).Value
adressDevice = sh.Range("Q" & i)
copyrange.Copy
Sheets("Summary").Select
LastRowsummary = ActiveSheet.Range("A1048555").End(xlUp).Row
Range("B" & LastRowsummary + 1).Select
ActiveSheet.Paste
Range("A" & LastRowsummary + 1) = sh.Name
Range("A" & LastRowsummary + 1, "O" & LastRowsummary + 1).Borders.LineStyle = xlContinuous
Sheets("Summary").Hyperlinks.Add anchor:=Sheets("Summary").Range("N" & LastRowsummary + 1), Address:="", SubAddress:="'" & sh.Name & "'!A1", TextToDisplay:=NameDevice
End If
Next
End If
Next
Application.ScreenUpdating = True
Sheets("Summary").Activate
End Sub
* edit :經過一些測試,我注意到當我使用全范圍的列而不是僅某些列時,錯誤消失了。
錯誤:
Set copyrange = sh.Range("A" & i & ",V" & i)
沒有錯誤:
Set copyrange = sh.Range("A" & i & ":E" & i)
*第二次編輯:
我正在使用“蒂姆·威廉姆斯”中的代碼。 出現相同的錯誤。 而不是使用:
rw.Range("A1:E1,I1:O1,Q1,V1").Copy rng.Offset(0, 1)
我找到了一種解決方法。 我分開了。
rw.Range("I1:O1").Copy rng.Offset(0, 6)
rw.Range("Q1").Copy rng.Offset(0, 13)
rw.Range("V1").Copy rng.Offset(0, 14)
現在這可以正常工作了。 但是,如果有人知道導致問題的原因,則可以隨時與他人分享。 提前致謝。
*第三次編輯:
我仍然不知道為什么它不起作用。 它與不同列中的范圍有關。 有趣的是(很沮喪的一部分),我在另一張紙上以這種方式使用范圍,所以我沒有這個問題。 它使我發瘋。 有人有主意嗎?
已編譯但未經測試”
Private Sub btnGetDevices_Click()
'open every sheet after summary
'copy columns A,B,C,D,E,I,J,K,L,M,N,O, Q,V to summary
Dim sh As Worksheet, shtsumm As Worksheet
Dim copyrange As Range, arrExclude, rw As Range
Dim lastRow As Long, i As Long, rng As Range
Dim NameDevice, adressDevice
'sheets to ignore
arrExclude = Array("Database", "Template", "Help", "OVERVIEW", _
"Develop", "Schedule", "Information", "Announcements", _
"Summary")
Set shtsumm = Sheets("Summary")
Application.ScreenUpdating = False
shtsumm.Rows(4 & ":" & shtsumm.Rows.Count).Delete
For Each sh In ActiveWorkbook.Worksheets
If IsError(Application.Match(sh.Name, arrExclude, 0)) Then
lastRow = sh.Cells(sh.Rows.Count, "L").End(xlUp).Row
For i = 14 To lastRow
Set rw = sh.Rows(i)
If rw.Cells(1, "Q").Value <> Empty And _
rw.Cells(1, "N").Value <> "Designer" And _
rw.Cells(1, "O").Value <> "Layouter" Then
NameDevice = rw.Range("Q1").Value
adressDevice = rw.Range("Q1").Value '<<<typo ?
'find destination
Set rng = shtsumm.Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
rng.Value = sh.Name
'Here Range is relative to *rw*, not to the whole sheet
rw.Range("A1:E1,I1:O1,Q1,V1").Copy rng.Offset(0, 1)
rng.Resize(1, 15).Borders.LineStyle = xlContinuous
shtsumm.Hyperlinks.Add _
anchor:=rng.EntireRow.Cells(1, "N"), _
Address:="", SubAddress:="'" & sh.Name & "'!A1", _
TextToDisplay:=NameDevice
End If
Next
End If
Next
Application.ScreenUpdating = True
shtsumm.Activate
End Sub
聲明:本站的技術帖子網頁,遵循CC BY-SA 4.0協議,如果您需要轉載,請注明本站網址或者原文地址。任何問題請咨詢:yoyou2525@163.com.