返回列表 上一主題 發帖

[發問] 請問vba是否可以依指定條件複製出不同excel工作表?

kathych

帖子
4 
主題
1 
精華
0 
積分
5 
點名
0  
作業系統
Win 
軟體版本
7 
閱讀權限
10 
性別
女 
註冊時間
2016-4-27 
最後登錄
2016-5-31 
1# 跳轉到 » 正序看帖
打印
tT
發表於 2016-4-28 18:09 | 只看該作者

[發問] 請問vba是否可以依指定條件複製出不同excel工作表?

各位大大好,

因為公司員工的薪資結構不同,每月都必須手動以excel 製作薪資條後再以pdf檔加密寄給員工,非常耗時又容易出錯.
請問是否可於excel 中設定巨集直接複製出不同工作表並帶入相對應資料?
比如附件中,薪資彙總計算於"總表", 員工甲~戊適用的薪資條格式分別如下:
員工姓名        適用表單
甲        A
乙        B
丙        C
丁        B
戊        A

Test.rar (21.1 KB)

請問:
   Q1: 是否可自動產生工作表名稱分別為員工姓名"甲"~"戊"的薪資條並將相關數據帶入?
   Q2: 完成後可否轉檔為加密的pdf檔?

麻煩&感謝各位囉!

Test.rar (21.1 KB)

Test.rar (21.1 KB)

Test.rar (21.1 KB)

收藏 分享
kathych

kathych

帖子
4 
主題
1 
精華
0 
積分
5 
點名
0  
作業系統
Win 
軟體版本
7 
閱讀權限
10 
性別
女 
註冊時間
2016-4-27 
最後登錄
2016-5-31 
9#
發表於 2016-5-5 12:41 | 只看該作者
謝謝版大的說明,已經了解了.
kathych

TOP

准提部林

帖子
2842 
主題
10 
精華
0 
積分
2898 
點名
0  
作業系統
〔略〕 
軟體版本
〔略〕 
閱讀權限
100 
性別
男 
來自
〔略〕 
註冊時間
2013-5-13 
最後登錄
2025-4-28 
8#
發表於 2016-5-4 20:14 | 只看該作者
本帖最後由 准提部林 於 2016-5-4 20:16 編輯

回復 7# kathych


〔業務〕工作表，Ｃ２輸入〔甲〕，
Ｃ３：=VLOOKUP($C$2,總表!$A:$R,MATCH(TRIM(B3),總表!$2:$2,),)
公式下拉至Ｃ１２，再貼至Ｅ３：Ｅ１２
這最基本的VLOOKUP函數，應不須多做解釋，
將公式貼成〔值〕，這時公式值有〔數字．０．錯誤值(#N/A)〕三種結果，
以下程式即做加工處理：以〔取代〕方法，清除〔０．錯誤值(#N/A)〕
With xS.[C3:E12]
　　　.Value = .Value
　　　.Replace "#N/A", "", LookAt:=xlWhole
　　　.Replace "0", ""
End With

程式碼的公式：.FormulaR1C1 = "=VLOOKUP(R2C3,總表!C1:C18,MATCH(TRIM(RC[-1]),總表!R2,),)"
是用〔錄製〕取得的，可自行試看看！！！

會用 TRIM(B3) 是因為Ｂ３文字含有〔空白字元〕，必須去除，才能準確抓取對應值，
另．〔總表〕的〔標題列．第二列〕的文字也可能因輸入手誤而含空白字元，
所以程式開頭即以：
[總表!2:2].Replace " ", "", LookAt:=xlPart　做取代，以清除空白字元!

TOP

kathych

帖子
4 
主題
1 
精華
0 
積分
5 
點名
0  
作業系統
Win 
軟體版本
7 
閱讀權限
10 
性別
女 
註冊時間
2016-4-27 
最後登錄
2016-5-31 
7#
發表於 2016-5-4 18:23 | 只看該作者
非常感謝各位,測試成功
~~雖然還在思索程式的意思才能讓它套用在我的日常作業中.

想請問版大,可以先幫我解惑以下的意思嗎? 不甚感激! 謝謝!
xS.[C3:C12,E3:E12].FormulaR1C1 = "=VLOOKUP(R2C3,總表!C1:C18,MATCH(TRIM(RC[-1]),總表!R2,),)"
kathych

TOP

ML089

帖子
2025 
主題
13 
精華
0 
積分
2053 
點名
0  
作業系統
WIN7 
軟體版本
Office2007 
閱讀權限
100 
性別
男 
來自
台北市 
註冊時間
2011-3-2 
最後登錄
2024-3-14 

論壇榮譽勳章論壇贊助勳章熱烈參與勳章2014馬年全勤獎章2015羊年全勤獎章2016猴年全勤獎章
6#
發表於 2016-5-1 16:21 | 只看該作者
回復 5# 准提部林

若有安裝 Adobe Acrobat 專業版時，用存檔為 PDF就可

原程式
        '    With ActiveWorkbook
        '         .Sheets(1).Name = "薪資條"
        '         .SaveAs xPH & xR & "-" & Format(Date - 7, "yyyymm") & "月薪資條.xls", CreateBackup:=False
        '         .Close
        '    End With
改為
        With ActiveWorkbook
            .Sheets(1).Name = "薪資條"
            ActiveSheet.ExportAsFixedFormat _
                    Type:=xlTypePDF, Filename:=xPH & xR & "-" & Format(Date - 7, "yyyymm") & "月薪資條.pdf", _
                    Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, _
                    OpenAfterPublish:=True
            .Close
        End With
{...} 表示需要用 CTRL+SHIFT+ENTER 三鍵輸入公式

TOP

准提部林

帖子
2842 
主題
10 
精華
0 
積分
2898 
點名
0  
作業系統
〔略〕 
軟體版本
〔略〕 
閱讀權限
100 
性別
男 
來自
〔略〕 
註冊時間
2013-5-13 
最後登錄
2025-4-28 
5#
發表於 2016-5-1 11:34 | 只看該作者
本帖最後由 准提部林 於 2016-5-1 11:36 編輯

公式+VBA,
只能產生活頁簿, PDF自行去想辦法,
  1. Sub TEST()
  2. Dim xR As Range, xS As Worksheet, xPH$
  3. xPH = ThisWorkbook.Path & "\"
  4. [總表!2:2].Replace " ", "", LookAt:=xlPart
  5. Application.ScreenUpdating = False
  6. For Each xR In Range([總表!A3], [總表!A65536].End(xlUp))
  7.     If xR.Row < 3 Then Exit Sub
  8.     If xR = "" Or xR(1, 2) = "" Then GoTo 101
  9.     Set xS = Sheets(xR(1, 2) & "")
  10.     xS.[C2] = xR
  11.     xS.[E2] = Format(Date - 7, "mmm.,yyyy")
  12.    
  13.     xS.[C3:C12,E3:E12].FormulaR1C1 = "=VLOOKUP(R2C3,總表!C1:C18,MATCH(TRIM(RC[-1]),總表!R2,),)"
  14.     With xS.[C3:E12]
  15.          .Value = .Value
  16.          .Replace "#N/A", "", LookAt:=xlWhole
  17.          .Replace "0", ""
  18.     End With
  19.    
  20.     xS.Copy
  21.     Application.DisplayAlerts = False
  22.     With ActiveWorkbook
  23.          .Sheets(1).Name = "薪資條"
  24.          .SaveAs xPH & xR & "-" & Format(Date - 7, "yyyymm") & "月薪資條.xls", CreateBackup:=False
  25.          .Close
  26.     End With
  27.     xS.[C3:C12,E3:E12,C2,E2] = ""
  28. 101: Next
  29. End Sub
複製代碼
附檔：
Xl0000004.rar (14.4 KB)
另一載址：
http://www.funp.net/954803　

TOP

luhpro

帖子
835 
主題
6 
精華
0 
積分
915 
點名
0  
作業系統
Win 10,7 
軟體版本
2019,2013,2003 
閱讀權限
50 
性別
男 
註冊時間
2010-5-3 
最後登錄
2024-11-14 
4#
發表於 2016-5-1 05:10 | 只看該作者
本帖最後由 luhpro 於 2016-5-1 05:16 編輯

回復 3# kathych
  1. Private Sub cbCreat_Click()
  2.   Dim iCol%, iCols%
  3.   Dim lSRow&, lTRow&
  4.   Dim sPath$, sStr1$, sStr2$
  5.   Dim wsTar As Worksheet
  6.   Dim vD As Object
  7.   
  8.   Set vD = CreateObject("Scripting.Dictionary")
  9.   sPath = ThisWorkbook.Path
  10.   ChDrive sPath
  11.   ChDir sPath
  12.   
  13.   With Sheets("總表")
  14.     iCols = .Cells(2, Columns.Count).End(xlToLeft).Column
  15.     iCol = 1
  16.     While iCol <= iCols
  17.       If .Cells(2, iCol) <> "" Then vD(Trim(.Cells(2, iCol))) = iCol
  18.       iCol = iCol + 1
  19.     Wend
  20.    
  21.     lSRow = 3
  22.     While .Cells(lSRow, 1) <> ""
  23.       Set wsTar = Sheets(CStr(.Cells(lSRow, 2)))
  24.       With wsTar
  25.         .[C2:C14].ClearContents
  26.         .[E3:E14].ClearContents
  27.         With .[E2] ' 月底那週就可以產生次月的薪資條
  28.           .NumberFormat = "mmm.,yyyy"
  29.           .Value = Now() - 7
  30.         End With
  31.       End With
  32.       
  33.       wsTar.[C2] = .Cells(lSRow, vD("員工姓名"))
  34.       
  35.       lTRow = 3
  36.       Do While 1
  37.         If wsTar.Cells(lTRow, 2) <> "" Or wsTar.Cells(lTRow, 4) <> "" Then
  38.           sStr1 = Trim(wsTar.Cells(lTRow, 2))
  39.           If sStr1 = "Total" Then Exit Do ' 遇到 Total 跳出迴圈
  40.           sStr2 = Trim(wsTar.Cells(lTRow, 4))
  41.           If sStr1 <> "" Then wsTar.Cells(lTRow, 3) = .Cells(lSRow, vD(sStr1))
  42.           If sStr2 <> "" Then wsTar.Cells(lTRow, 5) = .Cells(lSRow, vD(sStr2))
  43.         End If
  44.         lTRow = lTRow + 1
  45.       Loop
  46.       
  47.       With wsTar
  48.         .Copy ' 經實測,本行跳行時會另產生一個工作簿並貼上第一個工作表, 所以可以不用加 PasteSpecial 指令
  49.         With ActiveSheet
  50.           .Name = "薪資條"
  51.           With .Parent
  52.             .SaveAs wsTar.[C2] & "-" & Format(wsTar.[E2], "yyyymm") & "薪資條.xls"
  53.             .Close
  54.           End With
  55.         End With
  56.         
  57.         .PrintPreview
  58.         ' 這裡放轉成PDF檔的指令,還沒測試出來怎麼做
  59.       
  60.         .[C2:C14].ClearContents
  61.         .[E3:E14].ClearContents
  62.       End With
  63.       lSRow = lSRow + 1
  64.     Wend
  65.   End With
  66. End Sub
複製代碼
Test2-a.zip (17.51 KB)

TOP

kathych

帖子
4 
主題
1 
精華
0 
積分
5 
點名
0  
作業系統
Win 
軟體版本
7 
閱讀權限
10 
性別
女 
註冊時間
2016-4-27 
最後登錄
2016-5-31 
3#
發表於 2016-4-29 17:48 | 只看該作者
大大,非常感謝您,測試結果很成功.

但依老闆指示需做以下幾點修改,需要您的進一步協助.
1. A~C的制式表單改依"職稱"命名且格式稍作修改(=>將薪資減項另列於新增欄位)
2. 需改為產出以員工姓名命名的Excel薪資條,因為有時需再另行加註說明一些事項.
p.s. 若無法讓加註說明後的excel薪資條以巨集直接轉成加密pdf,則轉成pdf的功能可先不用考慮列入.

再次麻煩您了,謝謝!
Test2.rar (16.87 KB)
kathych

TOP

luhpro

帖子
835 
主題
6 
精華
0 
積分
915 
點名
0  
作業系統
Win 10,7 
軟體版本
2019,2013,2003 
閱讀權限
50 
性別
男 
註冊時間
2010-5-3 
最後登錄
2024-11-14 
2#
發表於 2016-4-29 01:41 | 只看該作者
回復 1# kathych

  1. Private Sub cbCreat_Click()
  2.   Dim iCol%, iCols%
  3.   Dim lSRow&, lTRow&
  4.   Dim sStr$
  5.   Dim bNDone As Boolean
  6.   Dim wsTar As Worksheet
  7.   Dim vD As Object
  8.   
  9.   Set vD = CreateObject("Scripting.Dictionary")

  11.   With Sheets("總表")
  12.     iCols = .Cells(2, Columns.Count).End(xlToLeft).Column
  13.     iCol = 1
  14.     While iCol <= iCols
  15.       If .Cells(2, iCol) <> "" Then vD(Trim(.Cells(2, iCol))) = iCol
  16.       iCol = iCol + 1
  17.     Wend
  18.    
  19.     lSRow = 3
  20.     While .Cells(lSRow, 1) <> ""
  21.       Set wsTar = Sheets(.Cells(lSRow, 2) & " Form")
  22.       wsTar.[C2:C16].ClearContents
  23.       lTRow = 2
  24.       bNDone = True
  25.       While bNDone
  26.         If wsTar.Cells(lTRow, 2) <> "" And wsTar.Cells(lTRow, 2) <> "減:" Then
  27.           sStr = Trim(wsTar.Cells(lTRow, 2))
  28.         If wsTar.Cells(lTRow, 2) = "實領金額" Then
  29.           sStr = "淨額"
  30.           bNDone = False
  31.         End If
  32.           If InStr(1, sStr, ":") <> 0 Then sStr = Left(sStr, InStr(1, sStr, ":") - 1)
  33.           wsTar.Cells(lTRow, 3) = .Cells(lSRow, vD(sStr))
  34.         End If
  35.         lTRow = lTRow + 1
  36.       Wend
  37.       ' 這裡放轉成PDF檔的指令,時間關係來不及做
  38.       wsTar.PrintPreview
  39.       wsTar.[C2:C16].ClearContents
  40.       lSRow = lSRow + 1
  41.     Wend
  42.   End With
  43. End Sub
複製代碼
Test-a.zip (18 KB)

TOP

        靜思自在 : 要比誰更受誰．不要比誰更怕誰。
返回列表 上一主題