Question

我的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

Answer 1

我遇到了与您相同的问题，只需替换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

我在哪里添加此功能

1 个答案: