Question

我现在对一个宏发疯了。

我花了几个小时在互联网上寻找解决方案，但我来到了必须寻求帮助的地步：（

我得到了

运行时错误'1004'应用程序定义的错误或对象定义的错误

就在这一行：Range(rngZelle1.Offset(1, 2)).Paste

Option Explicit

Sub import()
Dim bk As Workbook
Dim sh, asheet As Worksheet
Dim rngZelle, rngZelle1 As Range
Dim strSuchwort, sDate, sPath, sName As String

Application.ScreenUpdating = False

Set sh = ActiveSheet
strSuchwort = "test"

sPath = "C:\Users\stefan.******\Downloads\" 'you dont need to know my real name :P
sName = Dir(sPath & "*.xl*")
Do While sName <> ""
Set bk = Workbooks.Open(sPath & sName)

For Each asheet In ActiveWorkbook.Worksheets
asheet.Activate
    For Each rngZelle In Range("A:A")
                If UCase(rngZelle) Like UCase(strSuchwort) Then

                sDate = Right(rngZelle, 10)
                Range(rngZelle.Offset(2, 1), rngZelle.Offset(25, 1)).copy

                For Each rngZelle1 In sh.Range("A:A")
                If rngZelle1 = sDate Then

                Range(rngZelle1.Offset(1, 2)).Paste '<---- thats the line i get the error

                End If
               Next rngZelle1
            End If
    Next rngZelle
Next asheet

一切顺利到上述行。我试图通过“msgbox sdate”替换它以进行测试，但是进展顺利。

我真的没有得到，在上一个循环中，副本进展顺利。这似乎是粘贴线的全部。

我希望你们其中一个人可以帮助一个完全的菜鸟:)每一个帮助都非常感谢，因为我对此非常不满。

Answer 1

Paste是一种不能在Range对象上使用的工作簿方法。

相应的Range方法是PasteSpecial，它有4个可选参数。粘贴参数默认使用xlPasteType xlPasteAll。为清楚起见，我通常包括xlPasteType，即使使用默认值。

如果你改变：

Range(rngZelle1.Offset(1, 2)).Paste

为：

Range(rngZelle1.Offset(1, 2)).PasteSpecial xlPasteAll

您的代码应该有效。

Answer 2

根据@Scott Craner和@ user3598756的上述评论，需要进行一些“更正”：

Dim sh, asheet As Worksheet表示asheet As Worksheet和sh As Variant。

同样适用于Dim rngZelle , rngZelle1 As Range，只有第二个是Range而rngZelle As Variant。

结束宣言的第一部分，应该是：

Dim bk As Workbook
Dim sh As Worksheet, asheet As Worksheet
Dim rngZelle As Range, rngZelle1 As Range
Dim strSuchwort As String, sDate As String, sPath As String, sName As String

关于For Each asheet In ThisWorkbook.Worksheets循环：

无需asheet.Activate，您可以改为使用With asheet。
关于您的错误，如果复制＆gt;＆gt;在2个代码行中粘贴，您需要将Paste行的语法替换为“PasteSpecial xlPasteAll。

For each asheet Loop Code

For Each asheet In ThisWorkbook.Worksheets
    With asheet
        For Each rngZelle In .Range("A:A")
            If UCase(rngZelle.Value) Like UCase(strSuchwort) Then

                sDate = Right(rngZelle.Value, 10)
                Range(rngZelle.Offset(2, 1), rngZelle.Offset(25, 1)).Copy

                For Each rngZelle1 In sh.Range("A:A")
                    If rngZelle1.Value = sDate Then
                        rngZelle1.Offset(1, 2).PasteSpecial xlPasteAll
                    End If
                Next rngZelle1
            End If
        Next rngZelle
    End With
Next asheet

Answer 3

抱歉，我迟到了。不幸的是，过去几周我没有多少时间。

首先，.PasteSpecial完成了工作:)非常感谢！

Dim sh, asheet As Worksheet表示asheet As Worksheet和sh As Variant

非常感谢你的提示，我学到了一些新知识：）

不幸的是，with asheet和end with导致宏没有复制和粘贴数字，所以我坚持循环。

我设法构建了一个最终的工作宏，但它需要90分钟才能运行（最终版本将导入5倍的当前数据）并且在运行时会阻止剪贴板。

因此，如果有人知道如何加快速度并绕过剪贴板（复制目的地等因任何原因无法工作），那将非常感激。

Option Explicit

Sub import()
Dim bk As Workbook
Dim sh As Worksheet, asheet As Worksheet
Dim sSkill As Range, pval As Range, lstZelle As Range, target As Range, stype As Range, lstZelle1 As Range
Dim strSuchwort As String, sDate As String, sPath As String, sName As String, strSuchwort1 As String, strSuchwort2 As String
Dim row As Integer, col As Integer

Application.ScreenUpdating = False

Set sh = ActiveSheet
sPath = "C:\Users\*******\test\" 
sName = Dir(sPath & "*.xl*")

Do While sName <> ""
Set bk = Workbooks.Open(sPath & sName)

sh.Range("A1").AutoFilter field:=1, Criteria1:="<>"
For Each lstZelle In sh.Range("B:B")
If lstZelle <> "" Then
strSuchwort = lstZelle & "*"
strSuchwort2 = lstZelle.Offset(0, -1)

    For Each lstZelle1 In sh.Range("C:C")
    If lstZelle1 <> "" Then
    strSuchwort1 = lstZelle1

        For Each asheet In ActiveWorkbook.Worksheets
        asheet.Activate
        If asheet.Name = strSuchwort2 Then

            For Each sSkill In Range("A:A")
            If UCase(sSkill) Like UCase(strSuchwort) Then
            sDate = Right(sSkill, 10)

                For Each stype In Range(sSkill.Offset(1, 0), sSkill.Offset(1, 100))
                If UCase(stype) Like UCase(strSuchwort1) Then
                Range(stype.Offset(1, 0), stype.End(xlDown)).copy

                    For Each pval In sh.Range("1:1")
                    If pval = sDate Then
                    col = pval.Column
                    row = lstZelle.row
                    sh.Cells(row, col).PasteSpecial xlPasteValues

                    End If
                    Next pval
                End If
                Next stype
            End If
            Next sSkill
        End If
        Next asheet
    End If
    Next lstZelle1
End If
Next lstZelle

bk.Close SaveChanges:=False
sName = Dir()

Loop
Application.ScreenUpdating = True
sh.AutoFilterMode = False

End Sub

range.paste上的错误1004

3 个答案: