我在哪里添加此功能

问题描述

我的Excel工作簿中有一个宏，用于运行报告。 我想在下面添加pastespecial函数，但不知道将其放在脚本的更下方。它不断给我错误。我已经尝试了几乎所有线路。 我也想添加一个提取短语功能。我想从每个单元格的开头的一列中删除一些文本，例如：alpha / beta / kappa 请帮忙。谢谢。

++++++++++++++++++++++++++++++++++ 复制并粘贴值到不同的工作表 本示例将复制并粘贴不同工作表上单个单元格的值 1个 2

Sheets("Sheet1").Range("A1").Copy
Sheets("Sheet2").Range("B1").PasteSpecial Paste:=xlPasteValues

++++++++++++++++++++++++++++++++++++++

我在下面的代码中要插入上述pastespecial函数的位置： ++++++++++++++++++++++++++++++++++++++++++++++++++++ +++++++++++++++++++++++++++++

Option Explicit

Function GetHeadersDict() As Scripting.Dictionary
' We must activate the Microsoft Scripting Runtime from Tools --References

Dim result As Scripting.Dictionary

    Set result = New Scripting.Dictionary

    With result
     
        .Add "Track #",False
        .Add "Date",False
        .Add "Status",False
        .Add "Shoes",False
        .Add "Description",False
       
        
    End With

    Set GetHeadersDict = result
    
End Function

Function FindHeaderRange(ByVal ws As Worksheet,ByVal header As String) As Range

    Set FindHeaderRange = ws.Cells.Find(header,xlWhole)
    
End Function

Sub clearDataNotFormulasSheet2()

Sheets("Results").Range("A2:k96").ClearContents

End Sub


Sub copyColumnData()


On Error GoTo ErrorMessage
    
Dim ws1 As Worksheet,ws2 As Worksheet
    Set ws1 = ThisWorkbook.Sheets("Report")
    Set ws2 = ThisWorkbook.Sheets("Results")
    
    clearDataSheet2

Dim numRowsToCopy As Long

    numRowsToCopy = ws1.Cells(RowIndex:=Rows.Count,ColumnIndex:=1).End(xlUp).Row - 1
    'MsgBox "The no of rows to copy is " & numRowsToCopy
    
Dim destRowOffset As Long

    destRowOffset = ws2.Cells(RowIndex:=Rows.Count,ColumnIndex:=1).End(xlUp).Row
    'MsgBox "The next Blank row is " & destRowOffset

    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    
Dim dictKey As Variant
Dim header As String
Dim numColumnsToCopy As Long
Dim Report As Range
Dim dest As Range

Dim headersDict As Scripting.Dictionary

    Set headersDict = GetHeadersDict()

    For Each dictKey In headersDict
        header = dictKey
        If headersDict.Item(header) = False Then
            Set Report = FindHeaderRange(ws1,header)
            If Not (Report Is Nothing) Then
                Set dest = FindHeaderRange(ws2,header)
                If Not (dest Is Nothing) Then
                    headersDict.Item(header) = True
                    ' Look at successive headers to see if they match
                    ' If so,copy these columns altogether to make the macro faster
                    For numColumnsToCopy = 1 To headersDict.Count
                        'MsgBox numColumnsToCopy
                        If Report.Offset(ColumnOffset:=numColumnsToCopy).Value = dest.Offset(ColumnOffset:=numColumnsToCopy).Value Then
                            headersDict.Item(Report.Offset(ColumnOffset:=numColumnsToCopy).Value) = True
                            
                        Else
                            Exit For
                        End If
                        
                    Next numColumnsToCopy

                    Report.Offset(RowOffset:=1).Resize(RowSize:=numRowsToCopy,ColumnSize:=numColumnsToCopy).Copy _
                        dest.Offset(RowOffset:=destRowOffset)
                End If
            End If
        End If
    Next dictKey

Dim msg As String

    For Each dictKey In headersDict
        header = dictKey
        If headersDict.Item(header) = False Then
            msg = msg & vbNewLine & header
        End If
    Next dictKey

ExitSub:
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True

    If msg <> "" Then
        MsgBox "The following headers were not copied:" & vbNewLine & msg
    End If
Exit Sub

ErrorMessage:
    MsgBox "An error has occurred: " & Err.Description
    Resume ExitSub

End Sub


Private Sub CommandButton1_Click()

End Sub

解决方法

我遇到了与您相同的问题，只需替换Report.Offset(RowOffset:=1).Resize(RowSize:=numRowsToCopy,ColumnSize:=numColumnsToCopy).Copy _ dest.Offset(RowOffset:=destRowOffset)

与 Report.Offset(RowOffset:=1).Resize(RowSize:=numRowsToCopy,ColumnSize:=numColumnsToCopy).Copy dest.Offset(RowOffset:=destRowOffset).PasteSpecial Paste:=xlPasteValues