Private Sub Workbook_Open() ' Set 当前表 = ActiveSheet ' ' 文件短名称 = "查表填表.xlsm" ' 文件全名 = "D:余魁swvba" & 文件短名称 ' For Each kk In Workbooks ' Debug.Print kk.Name ' If kk.Name = 文件短名称 Then ' 已打开表 = True ' Exit For ' End If ' Next ' If Not 已打开表 Then ' Workbooks.Open 文件全名 ' End If ' ' 当前表.Activate Application.OnKey "%q", "粘贴到目的表" End Sub 'Application.OnKey 方法(Excel) ' 'office 365 dev account|上次更新日期: 2017/10/3|1 投稿人 '當按下特定鍵或組合鍵時會執行指定的程序。 ' '語法 ' '運算式 .OnKey(Key, Procedure) ' '運算式 代表 Application 物件的變數。 ' '參數 ' '名稱 必要/選用 資料類型 描述 'Key 必要 String 代表要按下按鍵的字串。 'Procedure 選用 Variant 指出要執行的程序之名稱字串。如果 Procedure 為 "" (空字串)，則在按下 Key 時並不會觸發任何作業。這種 OnKey 方法會變更 Microsoft Excel 中按鍵的正常結果。如果省略 Procedure，則 Key 會回復到其在 Microsoft Excel 中的正常結果，同時會清除先前使用 OnKey 方法指派的任何特殊鍵。 '註解 ' 'Key 參數可指定任何單個鍵，可指定任何與 ALT、CTRL 或 SHIFT 的組合鍵，還可以指定這些鍵的任何組合 (在 Windows 中)。每一鍵的名稱可由一個或多個字元表示，比如 "a" 表示字元 a，或者 "{ENTER}" 表示 ENTER 鍵。 ' '要指定非顯示文字符對應的鍵 (例如 ENTER 鍵或 TAB 鍵)，可使用下表所列示的代碼。表中的每一代碼表示鍵盤上的一個對應鍵。 ' '索引鍵 資料類型碼 'BACKSPACE {BACKSPACE} 或 {BS} 'BREAK {BREAK} 'CAPS LOCK {CAPSLOCK} 'CLEAR {CLEAR} 'DELETE 或 DEL {DELETE} 或 {DEL} '向下鍵 {DOWN} 'END {END} 'ENTER (數字小鍵盤) {ENTER} 'ENTER ~ (波狀符號) 'ESC { ESCAPE} 或 {ESC} 'HELP {HELP} 'HOME {HOME} 'INS {INSERT} '向左鍵 {LEFT} 'NUM LOCK {NUMLOCK} 'PAGE DOWN {PGDN} 'PAGE UP {PGUP} 'RETURN {RETURN} '向右鍵 {RIGHT} 'SCROLL LOCK {SCROLLLOCK} 'TAB {TAB} '向上鍵 {UP} 'F1 到 F15 {F1} 到 {F15} '您也可指定與 SHIFT 鍵和/或 CTRL 鍵和/或 ALT 鍵的組合鍵。要指定與這些鍵的組合可使用下表提供的方法。 ' '要組合的按鍵 在按鍵代碼之前加上 'SHIFT (加號) 'CTRL ^ (指數) 'ALT 鍵 % (百分號) '若為特定字元指定處理程序 (如 +、^、% 等等)，可將此字元用圓括弧括起。有關詳細資料，請參閱範例。 ' '範例 ' '本範例會為 CTRL + 加號的按鍵組合指派 "InsertProc"，並為 SHIFT + CTRL + 向右鍵的按鍵組合指派 "SpecialPrintProc"。 ' 'Application.OnKey "^{+}", "InsertProc" 'Application.OnKey "+^{RIGHT}", "SpecialPrintProc" '本範例會將 SHIFT + CTRL + 向右鍵回復到其正常意義。 ' 'Application.OnKey "+^{RIGHT}" '本範例會停用 SHIFT + CTRL + 向右鍵的按鍵組合。 ' 'Application.OnKey "+^{RIGHT}", ""
Sub 粘贴到目的表cs() Dim rng As Range Set rng = Application.InputBox("选择目的单元格", Type:=8) Debug.Print rng.Address Debug.Print rng.Row Debug.Print rng.AddressLocal Debug.Print rng.AddIndent Debug.Print rng.Cells(1, 1) Debug.Print rng.Worksheet Debug.Print rng.Worksheet.Cells(1, 1) End Sub Sub 粘贴到目的表() Debug.Print ThisWorkbook.Name On Error Resume Next 表头行 = ActiveSheet.Range("1:10").Find("此行为表头行").Row If 表头行 = 0 Then Exit Sub Set 拟粘贴表字典 = CreateObject("Scripting.Dictionary") Set 当前表头 = CreateObject("Scripting.Dictionary") 首列 = 1 Call 识别表头(当前表头) Set 拟粘贴行号 = CreateObject("Scripting.Dictionary") For Each c In Selection.Cells Debug.Print c.Row 拟粘贴行号.Add c.Row, "" Call Excel转字典单行(拟粘贴表字典, c.Row) Next 表头行 = ActiveSheet.Range("1:10").Find("目的表头行→").Offset(0, 1) '设置目的表的表头行默认值，公用了全局变量“表头行” 含数量 = (ActiveSheet.Range("1:10").Find("粘贴数量列？→").Offset(0, 1) = "是") Dim rng As Range On Error Resume Next Set rng = Application.InputBox("选择想粘贴到的 目的单元格", Type:=8) If rng Is Nothing Then Err.Clear: Exit Sub 目的行 = rng.Row rng.Worksheet.Activate On Error Resume Next 表头行 = ActiveSheet.Range("1:10").Find("此行为表头行").Row '如果目的表定义了表头行名称则覆盖前面的默认值 Set 目的表头 = CreateObject("Scripting.Dictionary") Call 识别表头(目的表头) '处理别名==开始 If 目的表头.Exists("名称及规格") And Not 当前表头.Exists("名称及规格") And 当前表头.Exists("名称") Then For Each 行号 In 拟粘贴行号 当前表头.Add "名称及规格", "" Set 拟粘贴表字典(行号)("名称及规格") = 拟粘贴表字典(行号)("名称") Next End If '处理别名==结束 Dim 目的单元格 As Range For Each 列名 In 目的表头 If 当前表头.Exists(列名) And 列名 <> "序号" Then If 列名 <> "数量" Or (列名 = "数量" And 含数量) Then 当前目的行 = 目的行 For Each 行号 In 拟粘贴行号 Set 目的单元格 = Cells(当前目的行, 目的表头(列名)) 目的单元格 = 拟粘贴表字典(行号)(列名) If 目的单元格.Value = "米2" Then 目的单元格.Characters(2, 1).Font.Superscript = True End If 当前目的行 = 当前目的行 + 1 Next End If End If Next End Sub Sub TestFind() Debug.Print ActiveSheet.Range("1:10").Find("目的表头行").Address End Sub '先将单元格的链接的位置设为单元格本身,如单元格"A1"的链接地址设为"A1" 'Private Sub Worksheet_FollowHyperlink(ByVal Target As Hyperlink) ' If Target.SubAddress = ActiveSheet.Name & "!A1" Then 'a1单元格的链接 ' 宏1 ' ElseIf Target.SubAddress = ActiveSheet.Name & "!A2" Then 'a2单元格的链接 ' 宏2 ' End If 'End Sub 'Sub 宏1() ' MsgBox "我的位置是" & ActiveCell.Address 'End Sub 'Sub 宏2() ' MsgBox "我的位置是" & ActiveCell.Address 'End Sub ' Sub test() MsgBox ActiveSheet.Rows.Count End Sub
Public 禁止改变 As Boolean Public 表头行 As Integer Public 末行 As Long ' Public 首列 As Integer Public 末列 As Integer Public 文件名称列号 As Integer Public 文件路径列号 As Integer Public 代号列号 As Integer Public 名称列号 As Integer Public 项目号列 As Integer Sub 获取行列号() 首列 = 1 表头行 = Range("表头行").Row ' 表头行 = ActiveSheet.Range("1:10").Find("此行为表头行").Row Cells.EntireColumn.Hidden = False If Cells(表头行 + 1, 首列) <> "" Then 末行 = Cells(表头行, 首列).End(xlDown).Row Else 末行 = 表头行 + 1 End If 末列 = Cells(表头行, 首列).End(xlToRight).Column 文件名称列号 = Range("文件名称").Column 文件路径列号 = Range("文件路径").Column 项目号列 = Range("项目号").Column 代号列号 = Range("代号").Column 名称列号 = Range("名称").Column End Sub Sub Excel转字典(ByRef 字典) 获取行列号 For 当前行 = 表头行 + 1 To 末行 Call Excel转字典单行(字典, 当前行) Next 当前行 End Sub Sub Excel转字典单行(ByRef 字典, ByVal 当前行) If Not 字典.Exists(当前行) Then Set 字典(当前行) = CreateObject("Scripting.Dictionary") For 列号 = 首列 To 末列 k = Cells(表头行, 列号) Set v = Cells(当前行, 列号) 字典(当前行).Add k, v Next End If End Sub Sub 清除() ' 获取行列号 ' Dim 末行% ' 末行 = Cells(65536, 文件名称列号).End(3).Row + 1 Cells(表头行 + 1, 1).Resize(末行 - 表头行, 末列).Interior.Pattern = xlNone Cells(表头行 + 1, 1).Resize(末行 - 表头行, 末列).ClearContents Cells.ClearOutline Cells(表头行 + 1, 1).Select End Sub Sub 识别表头(ByRef 表头) 末列 = Cells(表头行, 首列).End(xlToRight).Column For 列号 = 首列 To 末列 k = Cells(表头行, 列号) v = Cells(表头行, 列号).Column 表头.Add k, v Next End Sub
