Runtime error 1004 - Application-defined or object-defined error

Hi,

The following code was provided to me last night (thanks a bunch!!), but as I also need to identify which provider is responsible for the different sections that are listed, I have modified the sheets being copied to have the provider's name listed in column A for each row. When I changed the range to incorporate the changes I am now getting the following error:

Runtime error 1004 - Application-defined or object-defined error.

The line highlighted by the error is:

 Set rng = rng.Resize(rng.Rows.Count, rng.Columns.Count + 1).Offset(, -1)

Another issue I have is the merged cells that are in the worksheets being copied. If I use the PasteValues option, I get an error that the merged cells must be the same size. I need to use paste values to pull the doctors name in as column A on the source worksheets has a formula to populate that.

the code now reads: I have also attached a revised version of the example worksheet
the code is listed in Module5
Example Worksheet-3.xlsm

Sub Billing_CopyIt()

    Dim ws As Worksheet
    Dim wsOut As Worksheet: Set wsOut = ThisWorkbook.Sheets("Billing Temp")
    Dim rng As Range
    
    Application.ScreenUpdating = False
    
    For Each ws In ActiveWorkbook.Worksheets
        Select Case ws.Name
            Case Is = "Audit Temp", "Audit Summary", "Billing Temp", "Code_Table", "Master Provider List", "Accuracy Report Group", "Instructions"
                'do nothing
            Case Else
                On Error Resume Next
                Set rng = ws.Range("a23:j37").SpecialCells(2)
                On Error GoTo 0
                If Not rng Is Nothing Then
                    Set rng = rng.Resize(rng.Rows.Count, rng.Columns.Count + 1).Offset(, -1)
                    rng.Copy: wsOut.Range("A" & Rows.Count).End(xlUp)(2, 1).PasteSpecial xlPasteAll
                    Set rng = Nothing
                End If
        End Select
    Next ws
    
    Application.ScreenUpdating = True
    
End Sub

Any help is greatly appreciated

Carole

Hi,

I don't experience the first problem you describe when manually stepping through and running the macro. Would you let us know exactly what steps youj are taking that causes the macro to crash.

As for merged cells then my best advice is to avoid them like the plague. They really are far too much trouble than they are worth, causing many problems particularly in macros. Usually the simple formatting instruction 'Center across selection' achieves the same end.

No, sorry I still don't encounter a problem when running the Billing_CopyIt macro.
By stepping through it I merely meant running it one line of code at a time and watching for it to fall over - which it didn't.

I too am using Excel 2010 and Windows 8.1

I don't think the merged fields are absolutely necessary since you can achieve the same thing by using format centering across selection if required or indeed formatting left or right.

Hello missit,

If I understand this correctly then the attached workbook should do what you want. Check it out and let me know. The macro below has been added to Module7.

Option Explicit

Sub Macro1()

    Dim Data    As Variant
    Dim DstWks  As Worksheet
    Dim LastRow As Long
    Dim n       As Long
    Dim NextRow As Long
    Dim SrcRng  As Range
    Dim SrcWks  As Worksheet

        UnProtectall
        
        Set DstWks = ThisWorkbook.Sheets("Billing Temp")
        
            NextRow = DstWks.Cells(Rows.Count, "A").End(xlUp).Row
            NextRow = IIf(NextRow < 3, 3, NextRow + 1)
            
            For Each SrcWks In ThisWorkbook.Worksheets
                Select Case SrcWks.CodeName
                    Case "Sheet1", "Sheet2", "Sheet3", "Sheet4", "Sheet5", "Sheet6", "Sheet7"
                        ' Skip these worksheets
                    Case Else
                        Set SrcRng = SrcWks.Range("B23:J37")
                        LastRow = SrcRng.Cells(SrcRng.Rows.Count, SrcRng.Column + 1).End(xlUp).Row
                        
                        Set SrcRng = SrcRng.Resize(RowSize:=LastRow - SrcRng.Row + 1)
                        
                        ReDim Data(1 To SrcRng.Rows.Count, 1 To 10)
                
                            For n = 1 To SrcRng.Rows.Count
                                Data(n, 1) = SrcWks.Range("D4")
                                Data(n, 2) = Empty
                                Data(n, 3) = SrcRng.Item(n, 2)
                                Data(n, 4) = SrcRng.Item(n, 3)
                                Data(n, 5) = Empty
                                Data(n, 6) = SrcRng.Item(n, 5)
                                Data(n, 7) = SrcRng.Item(n, 6)
                                Data(n, 8) = SrcRng.Item(n, 7)
                                Data(n, 9) = Empty
                                Data(n, 10) = SrcRng.Item(n, 9)
                            Next n
                            
                        DstWks.Cells(NextRow, "A").Resize(n - 1, UBound(Data, 2)).Value = Data
                        NextRow = NextRow + n - 1
                End Select
            Next SrcWks
            
        ProtectAll
        
End Sub