ExcelVBA創建新作業表并將文本復制到單元格中

多年來，我一直在成功使用下面的代碼，但最近它已經停止作業。我已經升級到 Office 365，但仍然沒有樂趣。本質上，代碼應該復制作業表“回應”，粘貼來自“資料庫”的單元格副本并適當地命名新作業表。它繼續在作業簿中創建新作業表，直到資料庫串列結束。

如果我按原樣運行代碼，則會得到以下資訊：“運行時錯誤'1004'：Microsoft Excel 無法粘貼資料。” 當我查看作業表時，顯然代碼運行并創建了一個作業表“Response4”（我只給了資料庫 4 行要復制）。除錯突出顯示 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

uj5u.com熱心網友回復：

由于“粘貼鏈接”需要在粘貼之前選擇范圍，所以我會跳過它并創建一個方法來執行該功能。

另外 - 使用作業表變數來減少代碼中的重復并使維護更容易。

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

標籤：擅长vba复制

上一篇：Excel：選擇介于2個日期之間的日期

下一篇：如何在一個區域中找到最大的數字，然后在同一行中找到一個數字的值？