Question

我在尝试复制某些对象时遇到“应用程序定义或对象定义”错误。

我曾经制作过某个范围的.select和.copy，然后在我想复制范围的地方做一个.paste。虽然这很好用，但我想传递价值并避免使用.copy .paste方法。

所以，我对代码进行了一些更改，我无法消除“应用程序定义或对象定义”错误。

Sub PreencherFacturador()

Application.Calculation = xlManual

Dim ano, mes1, mes2, mes3, dia, provisorio, iniciomes, maxreativa, capacitiva As Double
Dim LastRow As Long
Dim CPE, nome1, nome2, strFile, DIRECT As String
Dim data As Date
Dim Rng As Range
Dim ptTable As PivotTable
Dim pi As PivotItem
Dim ecer As Object
Dim sgl As Object

' Preencher facturador

CPE = Sheets("Dados").Cells(15, 3).Value
numproposta = Sheets("Dados").Cells(4, 3).Value
cliente = Sheets("Dados").Cells(10, 3).Value
ano = Year(Sheets("Dados").Cells(4, 5).Value)
nome1 = ActiveWorkbook.Name

If CPE = "" Then
MsgBox "CPE não encontrado."
Exit Sub
End If

Set ecer = ActiveWorkbook.Sheets("Cálculos")

Application.StatusBar = "Preenchendo facturador. Por favor aguarde."
Application.ScreenUpdating = False
Application.EnableEvents = False
Sheets("Cálculos").Range("G3:L35046").ClearContents

'Consumos mes Janeiro a Agosto

For mes1 = 1 To 8

ChDrive "F"
ChDir "F:\Data3\SCF\SCFfiles\Backup"
strFile = "*" & CPE & "_" & ano & "0" & mes1 + 1 & "*.sgl"

If Len(Dir(strFile)) Then
Workbooks.Open Filename:=Dir(strFile)

'Set the workbook and the sheet i want
Set sgl = ActiveWorkbook.ActiveSheet

nome2 = ActiveWorkbook.Name
If Range("A2").Value = "" Then
Columns(1).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End If
LastRow = Cells(Rows.Count, 1).End(xlUp).Row

'HERE IT WORKS FINE
sgl.Range(Cells(4, 4), Cells(LastRow - 1, 9)).Select

dia = Right(Range("B4").Value, 2)

Windows(nome1).Activate
data = dia & "-" & "0" & mes1 & "-" & ano

With Sheets("Cálculos").Range("D:D")
Set Rng = .Find(What:=data, _
        After:=.Cells(.Cells.Count), _
        LookIn:=xlValues, _
        LookAt:=xlWhole, _
        SearchOrder:=xlByRows, _
        SearchDirection:=xlNext, _
        MatchCase:=False)

If Not Rng Is Nothing Then
        Application.GoTo Rng, True
        iniciomes = Rng.Row
End If
End With


'HERE IT DOESNT 
sgl.Range(Cells(4, 4), Cells(LastRow - 1, 9)).Select

Call CopyValues(sgl.Range(Cells(4, 4), Cells(LastRow - 1, 9)), ecer.Sheets    ("Cálculos").Cells(iniciomes, 7))

CopyValues方法是这样的：

Sub CopyValues(rngSource As Range, rngTarget As Range)

    rngTarget.Resize(rngSource.Rows.Count, rngSource.Columns.Count).Value = rngSource.Value

End Sub

我没有得到错误的位置，因为在代码的一部分中，对象选择很好，而在其他部分它没有。（我已经标记了代码的工作位置以及代码所在的位置）

提前致谢，

安德烈

Answer 1

我将此作为答案发布，因为所有这些都不会出现在评论中。

当我在上面的链接中提到你回答的时候就在那里。它确实做到了。在那个答案中还有一个链接。无论如何，这里又是INTERESTING READ

关于您的代码的一些事情。

正确声明对象并使用它们。避免使用上面链接中提到的.Activate/.Select。
使用代码顶部的Option Explicit。有许多变量如numproposta未声明。
当您将变量/对象声明为Dim ano, mes1, mes2, mes3, dia, provisorio, iniciomes, maxreativa, capacitiva As Double时，只有最后一个变量将声明为Double，其余变量将声明为Variant。如果你想要将它们全部声明为double，那么你必须将它们声明为Dim ano As Double, mes1 As Double, mes2 As Double, mes3 As Double, dia As Double, provisorio As Double, iniciomes As Double, maxreativa As Double, capacitiva As Double在下面的代码中，我已经将它们留下了。我相信你会单独和适当地宣布它们。
使用Exit For时要小心。如果您在开头设置了Application.Calculation = xlManual，然后使用Exit For，请记住它不会被重置。
如果Call CopyValues(sgl.Range(sgl.Cells(4, 4), sgl.Cells(LastRow - 1, 9)), ecer.Sheets("Cálculos").Cells(iniciomes, 7))未返回任何内容，则行.Find将失败，因为在这种情况下iniciomes将是0。

尝试使用此代码（ UNTESTED ）我只需通过声明变量/对象并完全限定它们来重新排列代码。

Option Explicit

Sub PreencherFacturador()
    Dim thisWb As Workbook, newWb As Workbook
    Dim ecer As Worksheet, sgl As Worksheet

    Dim ano, mes1, mes2, mes3, dia, provisorio, iniciomes, maxreativa, capacitiva As Double
    Dim LastRow As Long
    Dim CPE, nome1, nome2, strFile, DIRECT As String
    Dim data As Date
    Dim Rng As Range
    Dim ptTable As PivotTable
    Dim pi As PivotItem
    Dim numproposta, cliente

    ' Preencher facturador
    Set thisWb = ThisWorkbook

    CPE = thisWb.Sheets("Dados").Cells(15, 3).Value
    numproposta = thisWb.Sheets("Dados").Cells(4, 3).Value
    cliente = thisWb.Sheets("Dados").Cells(10, 3).Value
    ano = Year(thisWb.Sheets("Dados").Cells(4, 5).Value)

    nome1 = thisWb.Name

    If CPE = "" Then
        MsgBox "CPE não encontrado."
        Exit Sub
    End If

    Application.Calculation = xlManual
    Application.StatusBar = "Preenchendo facturador. Por favor aguarde."
    Application.ScreenUpdating = False
    Application.EnableEvents = False

    Set ecer = ActiveWorkbook.Sheets("Cálculos")
    ecer.Range("G3:L35046").ClearContents

    'Consumos mes Janeiro a Agosto
    For mes1 = 1 To 8
        ChDrive "F"
        ChDir "F:\Data3\SCF\SCFfiles\Backup"
        strFile = "*" & CPE & "_" & ano & "0" & mes1 + 1 & "*.sgl"

        If Len(Dir(strFile)) Then
            Set newWb = Workbooks.Open(Filename:=Dir(strFile))
            Set sgl = newWb.ActiveSheet

            nome2 = newWb.Name

            If sgl.Range("A2").Value = "" Then
                sgl.Columns(1).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
            End If

            LastRow = sgl.Cells(sgl.Rows.Count, 1).End(xlUp).Row

            dia = Right(sgl.Range("B4").Value, 2)

            data = dia & "-" & "0" & mes1 & "-" & ano

            With ecer.Range("D:D")
                Set Rng = .Find(What:=data, _
                        After:=.Cells(.Cells.Count), _
                        LookIn:=xlValues, _
                        LookAt:=xlWhole, _
                        SearchOrder:=xlByRows, _
                        SearchDirection:=xlNext, _
                        MatchCase:=False)

                If Not Rng Is Nothing Then
                        Application.GoTo Rng, True
                        iniciomes = Rng.Row
                End If
            End With

            If iniciomes <> 0 Then _
            Call CopyValues(sgl.Range(sgl.Cells(4, 4), sgl.Cells(LastRow - 1, 9)), _
            ecer.Cells(iniciomes, 7))

            '
            '~~> Rest of the code
            '
        End If
    Next

    Application.Calculation = xlAutomatic
    Application.StatusBar = ""
    Application.ScreenUpdating = True
    Application.EnableEvents = True
End Sub

使用对象在Excel上复制粘贴时出错

1 个答案: