excel 创建新工作表并将文本复制到单元格中

omqzjyyz 于 2023-06-07 发布在其他

关注(0)|答案(1)|浏览(223)

代码已使用多年，最近停止工作。
我已经升级到Office 365了。
代码应该复制工作表“响应”，粘贴一个单元格的副本从“数据库”，并命名新的工作表适当。它将继续在工作簿中创建新工作表，直到“数据库”列表结束。
我得到：
运行时错误“1004”：Microsoft Excel无法粘贴数据。
代码运行并创建一个工作表“Response4”。（我只给了数据库4行来复制。Debug突出显示ActiveSheet.Paste link:=True行。
代码在我公司的系统之外工作。（我把它和虚拟数据一起发给了一个朋友，它起作用了。）

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

excel

来源：https://stackoverflow.com/questions/74018189/create-new-sheet-and-copy-text-into-cell

1条答案

按热度按时间

9njqaruj1#

由于“粘贴链接”需要在粘贴之前选择范围，我会跳过这一点，并创建一个方法来执行该功能。
另外，使用工作表变量可以减少代码中的重复，并使维护更容易。

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

赞(0）回复(0）举报 2023-06-07

我来回答

excel 创建新工作表并将文本复制到单元格中

1条答案

相关问题

热门标签

最新问答