0

当我尝试复制一些对象时，我收到“应用程序定义或对象定义”错误。

我曾经制作某个范围的 .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

我不知道错误在哪里，因为在代码的一部分中，对象选择做得很好，而在另一部分则没有。（我已经用注释标记了代码工作的地方和不工作的地方）

提前致谢，

安德烈

4

1 回答 1

1

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

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

关于您的代码的几件事。

  1. 正确声明对象并使用它们。避免使用.Activate/.Select上面链接中提到的。

  2. Option Explicit在代码顶部使用。有很多numproposta没有声明的变量。

  3. 当您将变量/对象声明为时，Dim ano, mes1, mes2, mes3, dia, provisorio, iniciomes, maxreativa, capacitiva As Double只有最后一个变量将被声明为Double，其余的为Variant. 如果您希望所有这些都被声明为双精度，那么您必须将它们声明为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在下面的代码中，我已经将它们保留为这样。我相信你会单独和适当地声明它们。

  4. 使用时要小心Exit For。如果您Application.Calculation = xlManual在开始时已设置然后使用Exit For，请记住它不会被重置。

  5. 如果不返回任何内容，则该行将失败Call CopyValues(sgl.Range(sgl.Cells(4, 4), sgl.Cells(LastRow - 1, 9)), ecer.Sheets("Cálculos").Cells(iniciomes, 7))，因为在这种情况下。.Findiniciomes0

试试这段代码（未测试） 我只是通过声明变量/对象并完全限定它们来重新排列你的代码。

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
于 2013-11-08T12:29:57.360 回答