Excel VBA create new sheet and copy text into cell-CodePudding

I have been using the below code successfully for years but recently it has stopped working. I've since upgraded to Office 365 and still no joy. Essentially the code should copy the Sheet "Response", paste a copy of a cell from "Database" and name the new sheet appropriately. It continues creating new sheets in the workbook until the end of the Database list.

If I run the code as is I get the following: "Run-time error '1004': Microsoft Excel cannot paste the data." When I look at the worksheets, evidentally the code runs and creates a sheet "Response4" (I've only given the database 4 lines to copy). Debug highlights the line ActiveSheet.Paste link:=True. I tested

Frustratingly the code works outside of my company's system (i.e., I sent it to a friend with dummy data and it worked perfectly fine).

Any suggestions very welcome!

Sub CopyCatView()

'NumResp = last row with a responses to the question held within the question 'Themes' database sheet
Dim NumResp As Integer
'x for looping variable
Dim x As Integer
'y for response number variable
Dim y As Integer
Dim ws As Worksheet

Sheets("Database").Activate

NumResp = Range("NumRowsD1").Value   2
'NumRowsD1 is a named range comprising cell A1 on the Database sheet, which calculates by formula the number of comments in the database

For x = 3 To NumResp
    Sheets("Response").Copy before:=Sheets("Response")
    y = NumResp - x   1
    ActiveSheet.Name = "Response" & y
    ActiveSheet.Range("C2").Value = Sheets("Database").Range("B" & x).Value
    ActiveSheet.Range("AA5:CR5").Select
    Selection.Copy
    Sheets("Database").Select
    Cells(x, 3).Select
    ActiveSheet.Paste link:=True
    Sheets("Response" & y).Activate
    ActiveSheet.Range("F4").Select
    Selection.Copy
    Sheets("database").Select
    Cells(x, 70).Select
    ActiveSheet.Paste link:=True
'duplicates the Response sheet as many times as there are comments (=X), numbers them Response1 to ResponseX, copies each comment into the white box on a different response sheet from Response1 to ResponseX
'Also links through the check box reporting to the relevant row in the Database sheet
Next x
'at the end hide Sheet "Response"(deleting brings up prompts for every sheet deleted!)
Sheets("Response").Select
    ActiveWindow.SelectedSheets.Visible = False
    
    

Sheets("Database").Activate
Range("A1").Select


End Sub

CodePudding user response：

Since the "paste with link" requires ranges to be selected before pasting, I'd skip that and create a method to perform that function.

Also - use worksheet variables to reduce the repetition in your code and make for easier maintenance.

Sub CopyCatView()

    Dim NumResp As Long, x As Long, y As Long 'prefer Long over Integer
    Dim wsDB As Worksheet, wsResp As Worksheet, ws As Worksheet
    
    Set wsDB = ThisWorkbook.Worksheets("Database")
    Set wsResp = ThisWorkbook.Worksheets("Response")
    
    NumResp = wsDB.Range("NumRowsD1").Value   2
    
    For x = 3 To NumResp
        wsResp.Copy before:=wsResp
        Set ws = ThisWorkbook.Sheets(wsResp.Index - 1) 'get a reference to the copy
        y = NumResp - x   1
        ws.Name = "Response" & y
        ws.Range("C2").Value = wsDB.Range("B" & x).Value
        LinkRanges ws.Range("AA5:CR5"), wsDB.Cells(x, 3)
        LinkRanges ws.Range("F4"), wsDB.Cells(x, 70)
    Next x
    
    wsResp.Visible = False
        
    wsDB.Activate
    wsDB.Range("A1").Select

End Sub


'Link two ranges in the same workbook
'   rngFrom = contiguous (single-area) source range
'   rngTo = top-left cell of the destination range
Sub LinkRanges(rngFrom As Range, rngTo As Range)
    Dim r As Long, c As Long, nm As String
    If Not rngFrom.Parent Is rngTo.Parent Then
        nm = "'" & rngFrom.Parent.Name & "'!"
    End If
    For r = 1 To rngFrom.Rows.Count
        For c = 1 To rngFrom.Columns.Count
            rngTo.Cells(r, c).Formula = "=" & nm & _
                rngFrom.Cells(r, c).Address(False, False)
        Next c
    Next r
End Sub