麻辣家族討論版版 - Powered by Discuz! Board

Private Sub cbCreat_Click()
Dim iCol%, iCols%
Dim lSRow&, lTRow&
Dim sStr$
Dim bNDone As Boolean
Dim wsTar As Worksheet
Dim vD As Object
Set vD = CreateObject("Scripting.Dictionary")
With Sheets("總表")
iCols = .Cells(2, Columns.Count).End(xlToLeft).Column
iCol = 1
While iCol <= iCols
If .Cells(2, iCol) <> "" Then vD(Trim(.Cells(2, iCol))) = iCol
iCol = iCol + 1
Wend
lSRow = 3
While .Cells(lSRow, 1) <> ""
Set wsTar = Sheets(.Cells(lSRow, 2) & " Form")
wsTar.[C2:C16].ClearContents
lTRow = 2
bNDone = True
While bNDone
If wsTar.Cells(lTRow, 2) <> "" And wsTar.Cells(lTRow, 2) <> "減:" Then
sStr = Trim(wsTar.Cells(lTRow, 2))
If wsTar.Cells(lTRow, 2) = "實領金額" Then
sStr = "淨額"
bNDone = False
End If
If InStr(1, sStr, ":") <> 0 Then sStr = Left(sStr, InStr(1, sStr, ":") - 1)
wsTar.Cells(lTRow, 3) = .Cells(lSRow, vD(sStr))
End If
lTRow = lTRow + 1
Wend
' 這裡放轉成PDF檔的指令,時間關係來不及做
wsTar.PrintPreview
wsTar.[C2:C16].ClearContents
lSRow = lSRow + 1
Wend
End With
End Sub

複製代碼

Private Sub cbCreat_Click()
Dim iCol%, iCols%
Dim lSRow&, lTRow&
Dim sPath$, sStr1$, sStr2$
Dim wsTar As Worksheet
Dim vD As Object
Set vD = CreateObject("Scripting.Dictionary")
sPath = ThisWorkbook.Path
ChDrive sPath
ChDir sPath
With Sheets("總表")
iCols = .Cells(2, Columns.Count).End(xlToLeft).Column
iCol = 1
While iCol <= iCols
If .Cells(2, iCol) <> "" Then vD(Trim(.Cells(2, iCol))) = iCol
iCol = iCol + 1
Wend
lSRow = 3
While .Cells(lSRow, 1) <> ""
Set wsTar = Sheets(CStr(.Cells(lSRow, 2)))
With wsTar
.[C2:C14].ClearContents
.[E3:E14].ClearContents
With .[E2] ' 月底那週就可以產生次月的薪資條
.NumberFormat = "mmm.,yyyy"
.Value = Now() - 7
End With
End With
wsTar.[C2] = .Cells(lSRow, vD("員工姓名"))
lTRow = 3
Do While 1
If wsTar.Cells(lTRow, 2) <> "" Or wsTar.Cells(lTRow, 4) <> "" Then
sStr1 = Trim(wsTar.Cells(lTRow, 2))
If sStr1 = "Total" Then Exit Do ' 遇到 Total 跳出迴圈
sStr2 = Trim(wsTar.Cells(lTRow, 4))
If sStr1 <> "" Then wsTar.Cells(lTRow, 3) = .Cells(lSRow, vD(sStr1))
If sStr2 <> "" Then wsTar.Cells(lTRow, 5) = .Cells(lSRow, vD(sStr2))
End If
lTRow = lTRow + 1
Loop
With wsTar
.Copy ' 經實測,本行跳行時會另產生一個工作簿並貼上第一個工作表, 所以可以不用加 PasteSpecial 指令
With ActiveSheet
.Name = "薪資條"
With .Parent
.SaveAs wsTar.[C2] & "-" & Format(wsTar.[E2], "yyyymm") & "薪資條.xls"
.Close
End With
End With
.PrintPreview
' 這裡放轉成PDF檔的指令,還沒測試出來怎麼做
.[C2:C14].ClearContents
.[E3:E14].ClearContents
End With
lSRow = lSRow + 1
Wend
End With
End Sub

複製代碼

Sub TEST()
Dim xR As Range, xS As Worksheet, xPH$
xPH = ThisWorkbook.Path & "\"
[總表!2:2].Replace " ", "", LookAt:=xlPart
Application.ScreenUpdating = False
For Each xR In Range([總表!A3], [總表!A65536].End(xlUp))
If xR.Row < 3 Then Exit Sub
If xR = "" Or xR(1, 2) = "" Then GoTo 101
Set xS = Sheets(xR(1, 2) & "")
xS.[C2] = xR
xS.[E2] = Format(Date - 7, "mmm.,yyyy")
xS.[C3:C12,E3:E12].FormulaR1C1 = "=VLOOKUP(R2C3,總表!C1:C18,MATCH(TRIM(RC[-1]),總表!R2,),)"
With xS.[C3:E12]
.Value = .Value
.Replace "#N/A", "", LookAt:=xlWhole
.Replace "0", ""
End With
xS.Copy
Application.DisplayAlerts = False
With ActiveWorkbook
.Sheets(1).Name = "薪資條"
.SaveAs xPH & xR & "-" & Format(Date - 7, "yyyymm") & "月薪資條.xls", CreateBackup:=False
.Close
End With
xS.[C3:C12,E3:E12,C2,E2] = ""
101: Next
End Sub

複製代碼