返回列表 上一主題 發帖

[發問] 關於自動貼上連結至另一個檔案並自動插入超連結

stillfish00

帖子
1018 
主題
15 
精華
0 
積分
1058 
點名
0  
作業系統
win7 32bit 
軟體版本
Office 2016 64-bit 
閱讀權限
50 
性別
男 
來自
桃園 
註冊時間
2012-5-9 
最後登錄
2022-9-28 
1# 跳轉到 »
發表於 2015-5-6 13:53 | 顯示全部帖子
回復 27# starry1314
可試試看
  1. Sub 貼上資料至_業務管理TEST自動往下貼一行()
  2. '
  3. ' 貼上資料至_業務管理 巨集
  4. '
  5.     Dim lSourceRow As Long, lTargetRow As Long
  6.     Dim wsTarget As Worksheet
  7.    
  8.     With ActiveSheet
  9.         lSourceRow = .Buttons(Application.Caller).TopLeftCell.Row   '被點擊的該按鈕行數
  10.         Set wsTarget = Workbooks("客戶明細-業務專用.xlsm").Sheets(GetMonthStr(.Cells(lSourceRow, "B"))) '日期判斷要貼上的工作表
  11.         lTargetRow = wsTarget.Cells(Rows.Count, "B").End(xlUp).Row + 1  '要貼上的位置
  12.         .Range(.Cells(lSourceRow, "A"), .Cells(lSourceRow, "P")).Copy wsTarget.Cells(lTargetRow, "B") '複製貼上該行資料
  13.     End With
  14.    
  15.     'Q欄設定超連結到本檔案
  16.     With wsTarget
  17.         .Hyperlinks.Add Anchor:=.Cells(lTargetRow, "Q"), _
  18.                         Address:=ThisWorkbook.FullName, _
  19.                         SubAddress:=ThisWorkbook.ActiveSheet.Name & "!" & Rows(lSourceRow).Address, _
  20.                         TextToDisplay:=.Cells(lTargetRow, "Q").Text
  21.     End With
  22. End Sub

  24. '工作表用中文字要自己寫function轉，如果是1月、2月...可用 Format(日期,"m月")轉換較方便
  25. Function GetMonthStr(inDate As Date) As String
  26.     Select Case Month(inDate)
  27.         Case 1
  28.             GetMonthStr = "一月"
  29.         Case 2
  30.             GetMonthStr = "二月"
  31.         Case 3
  32.             GetMonthStr = "三月"
  33.         Case 4
  34.             GetMonthStr = "四月"
  35.         Case 5
  36.             GetMonthStr = "五月"
  37.         Case 6
  38.             GetMonthStr = "六月"
  39.         Case 7
  40.             GetMonthStr = "七月"
  41.         Case 8
  42.             GetMonthStr = "八月"
  43.         Case 9
  44.             GetMonthStr = "九月"
  45.         Case 10
  46.             GetMonthStr = "十月"
  47.         Case 11
  48.             GetMonthStr = "十一月"
  49.         Case 12
  50.             GetMonthStr = "十二月"
  51.     End Select
  52. End Function
複製代碼
表達不清、題意不明確、沒附檔案格式、沒有討論問題的態度~~~~~~以上愛莫能助。

TOP

stillfish00

帖子
1018 
主題
15 
精華
0 
積分
1058 
點名
0  
作業系統
win7 32bit 
軟體版本
Office 2016 64-bit 
閱讀權限
50 
性別
男 
來自
桃園 
註冊時間
2012-5-9 
最後登錄
2022-9-28 
2#
發表於 2015-5-6 16:12 | 顯示全部帖子
本帖最後由 stillfish00 於 2015-5-6 16:14 編輯

回復 30# starry1314
呼叫該巨集的按鈕，該按鈕左上角座標所在儲存格的行數
是根據客戶資料日期判斷，所以4/23跑完會貼到四月工作表
表達不清、題意不明確、沒附檔案格式、沒有討論問題的態度~~~~~~以上愛莫能助。

TOP

stillfish00

帖子
1018 
主題
15 
精華
0 
積分
1058 
點名
0  
作業系統
win7 32bit 
軟體版本
Office 2016 64-bit 
閱讀權限
50 
性別
男 
來自
桃園 
註冊時間
2012-5-9 
最後登錄
2022-9-28 
3#
發表於 2015-5-6 17:08 | 顯示全部帖子
回復 32# starry1314
可以，開啟兩檔案啟用巨集，按個別客戶的轉置-業務按鈕
四月工作表就有資料了
附件:
自動插入超連結.zip (431.58 KB)
表達不清、題意不明確、沒附檔案格式、沒有討論問題的態度~~~~~~以上愛莫能助。

TOP

stillfish00

帖子
1018 
主題
15 
精華
0 
積分
1058 
點名
0  
作業系統
win7 32bit 
軟體版本
Office 2016 64-bit 
閱讀權限
50 
性別
男 
來自
桃園 
註冊時間
2012-5-9 
最後登錄
2022-9-28 
4#
發表於 2015-5-7 09:56 | 顯示全部帖子
回復 35# starry1314
你怎麼套用的???
程式複製來源的是當前的工作表ActiveSheet
因為你的'收款跟催'工作表中該資料行有按鈕
按鈕觸發時的ActiveSheet就是收款跟催工作表
表達不清、題意不明確、沒附檔案格式、沒有討論問題的態度~~~~~~以上愛莫能助。

TOP

stillfish00

帖子
1018 
主題
15 
精華
0 
積分
1058 
點名
0  
作業系統
win7 32bit 
軟體版本
Office 2016 64-bit 
閱讀權限
50 
性別
男 
來自
桃園 
註冊時間
2012-5-9 
最後登錄
2022-9-28 
5#
發表於 2015-5-7 13:40 | 顯示全部帖子
回復 41# starry1314
再上傳檔案看看
表達不清、題意不明確、沒附檔案格式、沒有討論問題的態度~~~~~~以上愛莫能助。

TOP

stillfish00

帖子
1018 
主題
15 
精華
0 
積分
1058 
點名
0  
作業系統
win7 32bit 
軟體版本
Office 2016 64-bit 
閱讀權限
50 
性別
男 
來自
桃園 
註冊時間
2012-5-9 
最後登錄
2022-9-28 
6#
發表於 2015-5-7 19:57 | 顯示全部帖子
回復 43# starry1314
修改如下
  1. Sub 貼上資料至_業務管理TEST自動往下貼一行()
  2. '
  3. ' 貼上資料至_業務管理 巨集
  4. '
  5.     Dim lSourceRow As Long, lTargetRow As Long
  6.     Dim wsTarget As Worksheet
  7.    
  8.     With ActiveSheet
  9.         lSourceRow = .Buttons(Application.Caller).TopLeftCell.Row   '被點擊的該按鈕行數
  10.         If .Cells(lSourceRow, "B").Text = vbNullString Then MsgBox "日期欄無資料，無法判斷貼上月份": Exit Sub
  11.         Set wsTarget = Workbooks("客戶明細-業務專用.xlsm").Sheets(GetMonthStr(.Cells(lSourceRow, "B"))) '日期判斷要貼上的工作表
  12.         lTargetRow = wsTarget.Cells(Rows.Count, "B").End(xlUp).Row + 1  '要貼上的位置
  13.         Application.ScreenUpdating = False
  14.         .Range(.Cells(lSourceRow, "A"), .Cells(lSourceRow, "P")).Copy
  15.         wsTarget.Cells(lTargetRow, "B").PasteSpecial Paste:=xlPasteValues
  16.         wsTarget.Paste Link:=True
  17.         Application.ScreenUpdating = True
  18.     End With
  19.    
  20.     'R欄設定超連結到本檔案
  21.     With wsTarget
  22.         .Hyperlinks.Add Anchor:=.Cells(lTargetRow, "R"), _
  23.                         Address:=ThisWorkbook.FullName, _
  24.                         SubAddress:=ThisWorkbook.ActiveSheet.Name & "!" & Rows(lSourceRow).Address, _
  25.                         TextToDisplay:=ThisWorkbook.FullName
  26.         .Cells(lTargetRow, "R").HorizontalAlignment = xlLeft
  27.     End With
  28. End Sub
複製代碼
表達不清、題意不明確、沒附檔案格式、沒有討論問題的態度~~~~~~以上愛莫能助。

TOP

        靜思自在 : 受人點水之恩，須當湧泉以報。
返回列表 上一主題