|
|
本帖最后由 wulai8377 于 2024-7-17 17:29 编辑
Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hWnd As Long) As Long
Declare PtrSafe Function CloseClipboard Lib "user32" () As Long
Declare PtrSafe Function RegisterClipboardFormat Lib "user32.dll" Alias "RegisterClipboardFormatA" (ByVal lpString As String) As Long
Declare PtrSafe Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As Long
Declare PtrSafe Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
Declare PtrSafe Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Declare PtrSafe Function GlobalSize Lib "kernel32" (ByVal hMem As Long) As Long
Option Explicit
'**************************************************
Type RangeCellInfo '自定义类型存储宏运行所作出的改变
CellContent As Variant
CellAddress As String
End Type
Public OrgWB As Workbook
Public OrgWS As Worksheet
Public OrgCells() As RangeCellInfo
Private Function GetCutCopyRange() As Range
Dim sBuffer As String
Dim sItem As Variant
Dim hMem As Long
Dim nSize As Long
Dim lpData As Long
Dim lFormat As Long
Dim sWorkbook As String
Dim sSheet As String
Dim sRange As String
OpenClipboard 0&
lFormat = RegisterClipboardFormat("Link")
If lFormat <> 0 Then
hMem = GetClipboardData(lFormat)
If hMem <> 0 Then
lpData = GlobalLock(hMem)
If lpData <> 0 Then
nSize = GlobalSize(hMem)
sBuffer = Space(nSize)
CopyMemory ByVal StrPtr(sBuffer), ByVal lpData, ByVal nSize
sBuffer = StrConv(sBuffer, vbUnicode)
End If
GlobalUnlock hMem
Else
CloseClipboard
Exit Function
End If
End If
CloseClipboard
sItem = Split(sBuffer, Chr(0))
sItem(1) = Mid(sItem(1), InStr(sItem(1), "[") + 1)
sWorkbook = Left(sItem(1), InStr(sItem(1), "]") - 1)
sSheet = Mid(sItem(1), InStr(sItem(1), "]") + 1)
sRange = sItem(2)
Set GetCutCopyRange = Workbooks(sWorkbook).Sheets(sSheet).Range(Application.ConvertFormula(sRange, xlR1C1, xlA1))
End Function
'**************************************************
Sub 数值加()
' 在所有被选取的单元格中插入X
If Application.CutCopyMode = False Then Exit Sub '没有复制时退出本过程
'获取复制区域的行数和列数
Dim r As Range
Dim s As String
Dim a As String
Set r = GetCutCopyRange
If r Is Nothing Then
s = "目前剪贴板中没有Excel单元格区域"
Else
s = "工作簿：" & vbTab & r.Worksheet.Parent.FullName & vbCrLf
s = s & "工作表：" & vbTab & r.Worksheet.Name & vbCrLf
s = s & "单元格区域：" & vbTab & r.Address
s = s & "行数：" & vbTab & r.Rows.Count
s = s & "列数：" & vbTab & r.Columns.Count
End If
'MsgBox s'信息框
a = ActiveCell.Address '取得当前激活的单元格地址
Range(a).Resize(r.Rows.Count, r.Columns.Count).Select '以当前单元格为基础选定所复制的转置后的范围
Dim i As Integer, cl As Range
If TypeName(Selection) <> "Range" Then Exit Sub '如果被选中区域不是单元格（或者说如果鼠标焦点不再工作表中），那么结束过程
Application.ScreenUpdating = False '屏蔽刷新
ReDim OrgCells(Selection.Count)
Set OrgWB = ActiveWorkbook
Set OrgWS = ActiveSheet
i = 1
'记录下宏程序对工作表作出改变前的状态
For Each cl In Selection
OrgCells(i).CellContent = cl.Formula
OrgCells(i).CellAddress = cl.Address
i = i + 1
Next cl
Range(a).Resize(1, 1).Select '取消选择范围，重新激活当前单元格，防止多填充数据
' 转置数值 Macro
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlAdd, SkipBlanks _
:=False, Transpose:=False
'指定在“撤销”菜单项中的文字及选择该命令时所执行的宏程序
Application.OnUndo "撤销最后运行的宏过程操作", "UndoEditRange2"
End Sub
'**************************************************
'恢复工作表原先的状态
Sub UndoEditRange2()
Dim i As Integer
Application.ScreenUpdating = False
On Error GoTo NoWBorWS
OrgWB.Activate
OrgWS.Activate
On Error GoTo 0
'恢复宏运行所作的改变
For i = 1 To UBound(OrgCells)
Range(OrgCells(i).CellAddress).Formula = OrgCells(i).CellContent
Next i
Set OrgWB = Nothing
Set OrgWS = Nothing
Erase OrgCells
NoWBorWS:
End Sub
以上代码中标黄颜色的部分，在excel2007中正常，在2016中提示错误9，下标越界
那位大佬给看看吧
|
|
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2024-7-17 14:17
楼主
