- 帖子
- 471
- 主題
- 121
- 精華
- 0
- 積分
- 579
- 點名
- 0
- 作業系統
- WIN10
- 軟體版本
- OFFICE2019
- 閱讀權限
- 50
- 性別
- 男
- 註冊時間
- 2015-4-16
- 最後登錄
- 2023-1-17
|
3#
發表於 2015-6-4 15:47
| 只看該作者
已加入 但會跳出 執行程需或呼叫錯誤
- Sub 貼上資料至_客服管理_自動判斷()
- '
- ' 貼上資料至_客服管理 巨集
- Dim lSourceRow As Long, lTargetRow As Long
- Dim wsTarget As Worksheet
- Dim sPath$
- sPath = ThisWorkbook.Path
- ChDrive sPath
- ChDir sPath
- With ActiveSheet
- lSourceRow = .Buttons(Application.Caller).TopLeftCell.Row '被點擊的該按鈕行數
- If .Cells(lSourceRow, "C").Text = vbNullString Then MsgBox "日期欄無資料,無法判斷貼上月份": Exit Sub
- Set wsTarget = Workbooks("客戶明細-客服專用.xlsm").Sheets(GetMonthStr(.Cells(lSourceRow, "C"))) '日期判斷要貼上的工作表
- lTargetRow = wsTarget.Cells(Rows.Count, "B").End(xlUp).Row + 1 '要貼上的位置
- Application.ScreenUpdating = False
- .Range(.Cells(lSourceRow, "A"), .Cells(lSourceRow, "AF")).Copy '複製A欄到P欄的資料
- wsTarget.Cells(lTargetRow, "B").PasteSpecial Paste:=xlPasteValues '在B欄開始貼上
- wsTarget.Paste Link:=True '貼上連結
- Application.ScreenUpdating = True '貼上連結
- End With
-
- With wsTarget
- .Hyperlinks.Add Anchor:=.Cells(lTargetRow, "A"), _
- Address:=ThisWorkbook.FullName, _
- SubAddress:=ThisWorkbook.ActiveSheet.Name & "!" & Rows(lSourceRow).Address, _
- TextToDisplay:=.Cells(lTargetRow, "a").Text
- End With
- End Sub
複製代碼 回復 2# luhpro |
|