|
本帖最后由 wyzdddl 于 2012-8-15 22:22 编辑
下面是Thisworkbook
Private Sub Workbook_AddinInstall()
Dim myBar As Office.CommandBar
Dim imgSource As Office.CommandBarButton
Dim myControl1 As Office.CommandBarButton
' Add new command bar.
Set myBar = Application.CommandBars.Add(Name:="Custom", Position:=msoBarTop, Temporary:=False)
' Add 1 buttons to new command bar.
With myBar
.Controls.Add Type:=msoControlButton
.Visible = True
End With
' Paste Bold button face and set State of first button.
Set myControl1 = myBar.Controls(1)
Set imgSource = Application.CommandBars.FindControl(msoControlButton, 7433)
imgSource.CopyFace
With myControl1
.PasteFace
.State = msoButtonDown
.Caption = "自动粘帖"
.TooltipText = "自动粘帖切换控制按钮,点击切换。(开)"
.OnAction = "ButtonStateSwitch"
End With
End Sub
Private Sub Workbook_AddinUninstall()
Application.CommandBars("Custom").Delete
End Sub
Private Sub Workbook_Open()
InitializeApp
End Sub
下面是模块
Dim X As New EventClassModule
Public Sub InitializeApp()
Set X.App = Application
End Sub
Public Sub OpenButton()
With Application.CommandBars("Custom").Controls(1)
.State = msoButtonDown
.TooltipText = "自动粘帖切换控制按钮,点击切换。(开)"
End With
End Sub
Public Sub CloseButton()
With Application.CommandBars("Custom").Controls(1)
.State = msoButtonUp
.TooltipText = "自动粘帖切换控制按钮,点击切换。(关)"
End With
End Sub
Public Sub ButtonStateSwitch()
With Application.CommandBars("Custom").Controls(1)
Select Case .State
Case msoButtonDown
.State = msoButtonUp
.TooltipText = "自动粘帖切换控制按钮,点击切换。(关)"
Case msoButtonUp
.State = msoButtonDown
.TooltipText = "自动粘帖切换控制按钮,点击切换。(开)"
End Select
End With
End Sub
Function GetColumnDescription(ByVal Col As Long) As String
'将一个介入1-256之间(含两边)的数字转化成Excel所表示的列的序号,如"B"表示第2列,"DH"表示第112列
'返回的值为字符型,如果参数col不是数字,或不在1-256的范围内,则返回空字符串
If Col > 256 Or Col < 1 Or IsNumeric(Col) = False Then
GetColumnDescription = ""
Exit Function
End If
Dim CharArray(26) As Byte '字母数组
Dim lFirstChar, lLastChar As Long
Dim sFirstChar, sLastChar As String
CharArray(1) = Asc("A")
For i = 2 To 26
CharArray(i) = CharArray(i - 1) + 1
Next i
lFirstChar = Int(Col / 26)
If Col Mod 26 = 0 Then
'当lFirstChar是26的整数倍时,sFirstChar指向的是“Z”,但上面的公式却
'使sFirstChar指向另一个字母,因此要在下面调整过来
lFirstChar = lFirstChar - 1
End If
If lFirstChar > 0 Then
sFirstChar = Chr(lFirstChar + 64)
Else
sFirstChar = ""
End If
lLastChar = Col Mod 26
If lLastChar <> 0 Then
sLastChar = Chr(lLastChar + 64)
Else
sLastChar = "Z"
End If
GetColumnDescription = sFirstChar + sLastChar
End Function
下面是类模块
Const WorkbookNameSource = "腾远配件资料.xlsm"
Const WorkbookNameObject = "腾远进销管理系统.xlsm"
Const WorkSheetNameSource = "配件资料"
Const DoubleClickCol = 2 '双击某列时复制内容,此为 B 列
Const ColStartObject = 2 '粘帖内容的起始列,此为 B 列
Const MainWorkSheetRowCount = 149 '主表行的数量(含表头行数)
Const ColStartSource = 1 '复制内容的起始列,此为 A 列
Const ColCount = 5 '复制的列的数量
Public WithEvents App As Application
Private Sub App_SheetBeforeDoubleClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean)
If Application.CommandBars("Custom").Controls(1).State = msoButtonDown Then
If LCase(ActiveWorkbook.Name) = LCase(WorkbookNameSource) Then
If LCase(Sh.Name) = LCase(WorkSheetNameSource) Then
If Target.Column = DoubleClickCol Then '如果双击的列等于 DoubleClickCol 列,则...
Dim OP As Boolean '判断被粘贴的工作表是否打开
OP = False
For Each w In Workbooks
If LCase(w.Name) <> LCase(WorkbookNameObject) Then
OP = True: Exit For
End If
Next w
If OP = True Then
Dim RowStartObject As Long
With Workbooks(WorkbookNameObject).ActiveSheet
RowStartObject = 3
Do While RowStartObject > 0 '判断是否为空行
If Application.WorksheetFunction.CountA(Range(.Cells(RowStartObject, ColStartObject), .Cells(RowStartObject, ColStartObject))) > 0 Then
RowStartObject = RowStartObject + 1
ElseIf RowStartObject > MainWorkSheetRowCount Then
.Rows(RowStartObject).Insert Shift:=xlShiftDown
Exit Do
Else
Exit Do
End If
Loop
Range(Target.Offset(0, -1), Target.Offset(0, -1)).Copy
Range(.Cells(RowStartObject, 9), .Cells(RowStartObject, 9)).PasteSpecial Paste:=xlPasteValues
Range(Target.Offset(0, 0), Target.Offset(0, 1)).Copy
Range(.Cells(RowStartObject, 2), .Cells(RowStartObject, 3)).PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
Range(Target.Offset(0, 3), Target.Offset(0, 4)).Copy
Range(.Cells(RowStartObject, 6), .Cells(RowStartObject, 7)).PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
End With
'设置气球提示信息
Assistant.Visible = True
Set bln = Assistant.NewBalloon
With bln
.Heading = "从 [" & Left(WorkbookNameSource, InStrRev(WorkbookNameSource, ".") - 1) & " - " & Sh.Name & " - " & GetColumnDescription(ColStartSource) & Target.Row & ":" & GetColumnDescription(ColStartSource + ColCount - 1) & Target.Row & "] " & "到 [" & Left(WorkbookNameObject, InStrRev(WorkbookNameObject, ".") - 1) & " - " & Workbooks(WorkbookNameObject).ActiveSheet.Name & " - (" & GetColumnDescription(2) & RowStartObject & ":" & GetColumnDescription(3) & RowStartObject & "," & GetColumnDescription(5) & RowStartObject & ":" & GetColumnDescription(6) & RowStartObject & "," & GetColumnDescription(8) & RowStartObject & ")] 复制数据成功。"
.Text = "选择需要进行的操作."
.Labels(1).Text = "定位并选定 [" & Left(WorkbookNameObject, InStrRev(WorkbookNameObject, ".") - 1) & "!" & Workbooks(WorkbookNameObject).ActiveSheet.Name & "." & GetColumnDescription(2) & RowStartObject & ":" & GetColumnDescription(8) & RowStartObject & "] 单元格。"
.Labels(2).Text = "返回 [" & Left(WorkbookNameSource, InStrRev(WorkbookNameObject, ".") - 1) & "!" & Workbooks(WorkbookNameSource).ActiveSheet.Name & "] 工作表。"
.BalloonType = msoBalloonTypeButtons
.Mode = msoModeAutoDown
.Button = msoButtonSetNone
Select Case bln.Show
Case 1
Workbooks(WorkbookNameObject).Activate
Workbooks(WorkbookNameObject).ActiveSheet.Range(GetColumnDescription(2) & RowStartObject & ":" & GetColumnDescription(8) & RowStartObject).Select
Workbooks(WorkbookNameObject).ActiveSheet.Range(GetColumnDescription(4) & RowStartObject).Activate
Case 2
Workbooks(WorkbookNameSource).Activate
End Select
End With
Cancel = True
Else
Dim Msg, Style, Title, Response, MyString
End If
End If
End If
End If
End If
End Sub
Private Sub App_SheetActivate(ByVal Sh As Object)
' MsgBox Sh.Name
If LCase(ActiveWorkbook.Name) = LCase(WorkbookNameSource) And LCase(Sh.Name) = LCase(WorkSheetNameSource) Then
OpenButton
Else
CloseButton
End If
End Sub
Private Sub App_WorkbookActivate(ByVal Wb As Workbook)
' MsgBox Wb.Name
If LCase(Wb.Name) = LCase(WorkbookNameSource) And LCase(ActiveSheet.Name) = LCase(WorkSheetNameSource) Then
OpenButton
Else
CloseButton
End If
End Sub
|
|