如何解决我在哪里添加此功能
我的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
版权声明:本文内容由互联网用户自发贡献,该文观点与技术仅代表作者本人。本站仅提供信息存储空间服务,不拥有所有权,不承担相关法律责任。如发现本站有涉嫌侵权/违法违规的内容, 请发送邮件至 dio@foxmail.com 举报,一经查实,本站将立刻删除。