VBA Excel将动态范围从两个页面合并为一个，1004粘贴错误

时间：2012-01-07 22:49:00

标签： excel vba dynamic merge range

我正在尝试将来自两个不同电子表格的数据合并为一个，这将成为几个数据透视表的数据源。两个工作表都有不同的布局，所以我循环遍历第一个工作表以找到列，复制它下面的数据范围，然后粘贴到wDATA表。然后转到下一个工作表，找到相同的标题，然后粘贴到第一个块下面。 我得到了我最喜欢的错误，1004。我尝试了不同的礼仪和方法，但它不会粘贴，所以这就是我的开始。 Link是一个包含较大位和数据的文件。我保证干净。任何帮助？

            For x = 1 To iEndcol 'TOP SECTION OF DATA  -FBL5N
            If InStr(Cells(1, x), "Sold") Then
                Range(Cells(2, x), Cells(lEndRowA, x)).Copy _
                    Destination:=wDATA.Range(Cells(1, 1), Cells(lEndRowA, 1))
            ElseIf Cells(1, x) = "Invoice#" Then
                Range(Cells(2, x), Cells(lEndRowA, x)).Copy _
                    Destination:=wDATA.Range(Cells(1, 2), Cells(lEndRowA, 2))
            ElseIf Cells(1, x) = "Billing Doc" Then
                Range(Cells(2, x), Cells(lEndRowA, x)).Copy _
                    Destination:=wDATA.Range(Cells(1, 3), Cells(lEndRowA, 3))
            ElseIf InStr(Cells(1, x), "Cust Deduction") Then
                Range(Cells(2, x), Cells(lEndRowA, x)).Copy _
                    Destination:=wDATA.Range(Cells(1, 4), Cells(lEndRowA, 4))
            ElseIf Cells(1, x) = "A/R Adjustment" Then
                Range(Cells(2, x), Cells(lEndRowA, x)).Copy _
                    Destination:=wDATA.Range(Cells(1, 5), Cells(lEndRowA, 5))
            ElseIf InStr(Cells(1, x), "Possible Repay") Then
                Range(Cells(2, x), Cells(lEndRowA, x)).Copy _
                    Destination:=wDATA.Range(Cells(1, 6), Cells(lEndRowA, 6))
            ElseIf InStr(Cells(1, x), "Profit") Then
                Range(Cells(2, x), Cells(lEndRowA, x)).Copy _
                    Destination:=wDATA.Range(Cells(1, 7), Cells(lEndRowA, 7))
            End If
        Next
    End If
    ' DO NOT REDEFINE lEndrowA until all data is moved
    ' Fills in data from the second source, wLID
    If Not wLID Is Nothing Then
        wLID.Activate
        lEndRowB = Cells(4650, 1).End(xlUp).Row
        iEndcol = Cells(1, 1).End(xlToRight).Column
        For x = 1 To iEndcol 'BOTTOM
            If InStr(Cells(1, x), "Sold-To") Then
                Range(Cells(2, x), Cells(lEndRowB, x)).Copy _
                    Destination:=wDATA.Range(Cells(1, 1), Cells(lEndRowA + lEndRowB, 1))
            ElseIf Cells(1, x) = "Invoice#" Then
                Range(Cells(2, x), Cells(lEndRowB, x)).Copy _
                    Destination:=wDATA.Range(Cells(1, 2), Cells(lEndRowA + lEndRowB, 2))
            ElseIf Cells(1, x) = "Billing Doc" Then
                Range(Cells(2, x), Cells(lEndRowB, x)).Copy _
                    Destination:=wDATA.Range(Cells(1, 3), Cells(lEndRowA + lEndRowB, 3))
            ElseIf InStr(Cells(1, x), "Cust Deduction") Then
                Range(Cells(2, x), Cells(lEndRowB, x)).Copy _
                    Destination:=wDATA.Range(Cells(1, 4), Cells(lEndRowA + lEndRowB, 4))
            ElseIf Cells(1, x) = "A/R Adjustment" Then
                Range(Cells(2, x), Cells(lEndRowB, x)).Copy _
                    Destination:=wDATA.Range(Cells(1, 5), Cells(lEndRowA + lEndRowB, 5))
            ElseIf InStr(Cells(1, x), "Possible Repay") Then
                Range(Cells(2, x), Cells(lEndRowB, x)).Copy _
                    Destination:=wDATA.Range(Cells(1, 6), Cells(lEndRowA + lEndRowB, 6))
            ElseIf InStr(Cells(1, x), "Profit") Then
                Range(Cells(2, x), Cells(lEndRowB, x)).Copy _
                    Destination:=wDATA.Range(Cells(1, 7), Cells(lEndRowA + lEndRowB, 7))
            End If
        Next
    End If

2 个答案:

答案 0 :(得分：2)

问题在于这行代码：

wDATA.Range(Cells(1, 1), Cells(lEndRowA + lEndRowB, 1))

您已对Range对象进行了限定，但未对Cells个对象进行限定。没有资格，假定ActiveSheet。试试这个：

wDATA.Range(wDATA.Cells(1, 1), wDATA.Cells(lEndRowA + lEndRowB, 1))

答案 1 :(得分：2)

此代码存在许多问题

  1. 您没有对Range和Cells的所有引用进行限定。这导致参考活动表，而不是您想要的。
  2. 您正在复制源表中的公式，这会导致计算错误。可能想要复制值而不是
  3. 并非所有变量都已定义或设置
  4. 从wData复制时，您对FBL5N的索引会覆盖标题
  5. 从wData复制时，您对Line Item Detail的索引似乎有误（超越第一个数据集

    6. 这是你的代码重构，以纠正这些错误（请注意一些代码被注释掉，它没有任何意义）

    Option Explicit

Sub AR_Request_Populate()
'
'
'       WORKING
'       TODO: Pull in sales info and pricing folder, Finsih off Repay
'
'
'AR_Request_Populate Macro
' Refreshes Pivot Tables and fills out the AR Request sheet. Ends with copy,paste, special: values.
'
' Keyboard Shortcut: None
'

    Dim wb As Workbook
    Dim wFBL5N As Worksheet
    Dim wLID As Worksheet
    Dim wDATA As Worksheet
    Dim ws As Worksheet

    Dim iEndcol As Integer
    Dim lEndRowA As Long, lEndRowB As Long

    Dim i As Integer, j As Integer
    Dim y As Integer, x As Integer
    Dim v

    On Error Resume Next
    Set wb = ActiveWorkbook

    Set wLID = wb.Sheets("Line Item Detail")
    Set wFBL5N = wb.Sheets("FBL5N")
    If wFBL5N Is Nothing And wLID Is Nothing Then GoTo 102
    'On Error GoTo 101
    On Error GoTo 0

    'Application.ScreenUpdating = False
    wb.Sheets("wDATA").Visible = True
    Set wDATA = wb.Sheets("wDATA")

    ' Let's make a data sheet....
    ' DO NOT REDEFINE lEndrowA until all data is moved
    If Not wFBL5N Is Nothing Then
        With wFBL5N
            lEndRowA = .Cells(.Rows.Count, 1).End(xlUp).Row
            iEndcol = .Cells(1, .Columns.Count).End(xlToLeft).Column
            wFBL5N.Copy _
                after:=wb.Sheets("FBL5N")
            'Merges Ref. Key 1 into Profit Center
            For x = 1 To iEndcol
                If InStr(.Cells(1, x), "Profit") > 0 Then Exit For
            Next
            For j = 1 To iEndcol
                If InStr(.Cells(1, j), "Ref") > 0 And InStr(Cells(1, j), "1") > 0 Then Exit For
            Next
            For y = 1 To lEndRowA
                If IsEmpty(.Cells(y, x)) Then
                    .Cells(y, j).Copy Destination:=.Cells(y, x)
                End If
            Next
            'And we move it...
            For x = 1 To iEndcol 'TOP SECTION OF DATA  -FBL5N
                If InStr(.Cells(1, x), "Sold") Then
                    v = .Range(.Cells(2, x), .Cells(lEndRowA, x))
                    wDATA.Range(wDATA.Cells(2, 1), wDATA.Cells(lEndRowA, 1)) = v
                ElseIf .Cells(1, x) = "Invoice#" Then
                    v = .Range(.Cells(2, x), .Cells(lEndRowA, x))
                    wDATA.Range(wDATA.Cells(2, 2), wDATA.Cells(lEndRowA, 2)) = v
                ElseIf .Cells(1, x) = "Billing Doc" Then
                    v = .Range(.Cells(2, x), .Cells(lEndRowA, x))
                    wDATA.Range(wDATA.Cells(2, 3), wDATA.Cells(lEndRowA, 3)) = v
                ElseIf InStr(.Cells(1, x), "Cust Deduction") Then
                    v = .Range(.Cells(2, x), .Cells(lEndRowA, x))
                    wDATA.Range(wDATA.Cells(2, 4), wDATA.Cells(lEndRowA, 4)) = v
                ElseIf .Cells(1, x) = "A/R Adjustment" Then
                    v = .Range(.Cells(2, x), .Cells(lEndRowA, x))
                    wDATA.Range(wDATA.Cells(2, 5), wDATA.Cells(lEndRowA, 5)) = v
                ElseIf InStr(.Cells(1, x), "Possible Repay") Then
                    v = .Range(.Cells(2, x), .Cells(lEndRowA, x))
                    wDATA.Range(wDATA.Cells(2, 6), wDATA.Cells(lEndRowA, 6)) = v
                ElseIf InStr(.Cells(1, x), "Profit") Then
                    v = .Range(.Cells(2, x), .Cells(lEndRowA, x))
                    wDATA.Range(wDATA.Cells(2, 7), wDATA.Cells(lEndRowA, 7)) = v
                End If
            Next
        End With
    End If


    ' DO NOT REDEFINE lEndrowA until all data is moved
    ' Fills in data from the second source, wLID
    If Not wLID Is Nothing Then
        'wLID.Activate
        With wLID
            lEndRowB = .Cells(.Rows.Count, 1).End(xlUp).Row
            iEndcol = .Cells(1, 1).End(xlToRight).Column
            For x = 1 To iEndcol 'BOTTOM
                If InStr(.Cells(1, x), "Sold-To") Then
                    v = .Range(.Cells(2, x), .Cells(lEndRowB, x))
                    wDATA.Range(wDATA.Cells(lEndRowA + 1, 1), wDATA.Cells(lEndRowA + lEndRowB - 1, 1)) = v
                ElseIf .Cells(1, x) = "Invoice#" Then
                    v = .Range(.Cells(2, x), .Cells(lEndRowB, x))
                    wDATA.Range(wDATA.Cells(lEndRowA + 1, 2), wDATA.Cells(lEndRowA + lEndRowB - 1, 2)) = v
                ElseIf .Cells(1, x) = "Billing Doc" Then
                    v = .Range(.Cells(2, x), .Cells(lEndRowB, x))
                    wDATA.Range(wDATA.Cells(lEndRowA + 1, 3), wDATA.Cells(lEndRowA + lEndRowB - 1, 3)) = v
                ElseIf InStr(.Cells(1, x), "Cust Deduction") Then
                    v = .Range(.Cells(2, x), .Cells(lEndRowB, x))
                    wDATA.Range(wDATA.Cells(lEndRowA + 1, 4), wDATA.Cells(lEndRowA + lEndRowB - 1, 4)) = v
                ElseIf .Cells(1, x) = "A/R Adjustment" Then
                    v = .Range(.Cells(2, x), .Cells(lEndRowB, x))
                    wDATA.Range(wDATA.Cells(lEndRowA + 1, 5), wDATA.Cells(lEndRowA + lEndRowB - 1, 5)) = v
                ElseIf InStr(.Cells(1, x), "Possible Repay") Then
                    v = .Range(.Cells(2, x), .Cells(lEndRowB, x))
                    wDATA.Range(wDATA.Cells(lEndRowA + 1, 6), wDATA.Cells(lEndRowA + lEndRowB - 1, 6)) = v
                ElseIf InStr(.Cells(1, x), "Profit") Then
                    v = .Range(.Cells(2, x), .Cells(lEndRowB, x))
                    wDATA.Range(wDATA.Cells(lEndRowA + 1, 7), wDATA.Cells(lEndRowA + lEndRowB - 1, 7)) = v
                End If
            Next
        End With
    End If

99
    'wARadj.Select
   ' Range("A1:K1").Select
    MsgBox "All Done", vbOKOnly, "Yup."

100
    'wBDwrk.Visible = False
    'wPCwrk.Visible = False
    'wDATA.Visible = False
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
End

101     '101 and greater are error handlings for specific errors
    MsgBox "Sorry, there was an error and you might not be able to use this macro. If there are formula errors, delete the formulas and try the macro again. If this wasn't the problem, send a copy of this file and a breif message about what you were doing to me at:" _
    & vbNewLine & vbNewLine & "__________" & vbNewLine & vbNewLine & " I will try and let you know what happened ASAP.", , "I've gone Wonky."
GoTo 100

102
    MsgBox "This Macro can only run on a formatted Deduction Report or an FBL5N." _
        & vbNewLine & vbNewLine & "If you are using either one, please exactly name the tabs 'Line Item Detail' for a Dedution Report or 'FBL5N' for an FBL5N" _
            , vbOKOnly, "Line Item Detail or FBL5N Missing"
GoTo 100

End Sub
相关问题
最新问题