返回列表 上一主題 發帖

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

luhpro

帖子
835 
主題
6 
精華
0 
積分
915 
點名
0  
作業系統
Win 10,7 
軟體版本
2019,2013,2003 
閱讀權限
50 
性別
男 
註冊時間
2010-5-3 
最後登錄
2024-11-14 
1# 跳轉到 »
發表於 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

luhpro

帖子
835 
主題
6 
精華
0 
積分
915 
點名
0  
作業系統
Win 10,7 
軟體版本
2019,2013,2003 
閱讀權限
50 
性別
男 
註冊時間
2010-5-3 
最後登錄
2024-11-14 
2#
發表於 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

        靜思自在 : 為自己找藉口的人永遠不會進步。
返回列表 上一主題