Code to copy and paste not working

[missit]

Hi,

I have this code that worked once, but something changed and now it runs but doesn't pasted anything in my worksheet.

I have several worksheets in a workbook that all have similar data. I need to copy the same range from each worksheet with the exception of the following sheets, Audit Temp, Audit Summary, Accuracy Report Group and Master Provider List. I want to copy the range A23:H37 from all the other worksheets into my Billing Temp worksheet separated by blank row and then need to copy range "c4" from each worksheet and place the contents of it above the first range -- this identifies the provider name. I haven't figured out this part of the code yet. Please see example file.

Example Worksheet.xlsm

the code I have right now is:

Sub Billing_CopyIt()
    Dim ws As Worksheet
    Application.ScreenUpdating = False
    For Each ws In ActiveWorkbook.Worksheets
        If ws.Name <> "Audit Temp" And ws.Name <> "Audit Summary" ws.Name <> "Master Provider List" ws.Name <> "Accuracy Report Group" Then
            ws.Range("A23:H37").Copy
            Sheets("Billing Temp").Cells(Rows.Count, "A").End(xlUp).Offset(2).PasteSpecial xlPasteValues
        End If
    Next
    Application.ScreenUpdating = True
End Sub

This ran once and almost did what I needed, but I now it runs but doesn't paste anything in Billing Temp.

Thanks for your help in advance.

Carole

[AlphaFrog]

The code is working. In your example workbook, there is extraneous data in row 200 and below on sheet Billing Temp. All the other worksheet data is pasted below that data.

[missit]

oh my, thanks,

How can I prevent that from happening?

Carole

[berlan]

Hi Carole,

Alternative code (see attached with code saved in Module 5):

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("B23:H37").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 xlPasteValues
                    Set rng = Nothing
                End If
        End Select
    Next ws
    
    Application.ScreenUpdating = True
    
End Sub

Cheers, berlan

[missit]

this works great -- how can I add the contents of C4 above the first range and separate each group with a blank line between?

thanks so much for your effort.

Carole

[missit]

this works great -- how can I add the contents of C4 above the first range and separate each group with a blank line between?

thanks so much for your effort.

Carole

[missit]

Hi,

In an effort to try to resolve my issue with not having the provider's name associated with each of the sections, I added another column and entered a formula to place the provider's name on each row that has been filled in. To accommodate the extra column, I changed the range to ("a23:j37"), but now I am getting an error message in the code:
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)

the code now reads: I have also attached a revised version of the example worksheet.

Example Worksheet.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 xlPasteValues
                    Set rng = Nothing
                End If
        End Select
    Next ws
    
    Application.ScreenUpdating = True
    
End Sub

Thanks in advance for any assistance.

Carole