シートが存在しないとき削除
Dim sname As String
Dim i As Long
On Error Resume Next
rc = MsgBox("現金シートがすべて消えますがよろしいですか", vbYesNo + vbCritical)
If rc = vbYes Then
For i = 5 To 7
sname = "現金" & i & "月"
Application.DisplayAlerts = False
Worksheets(sname).Delete
Application.DisplayAlerts = True
Next
End If
Application.DisplayAlerts = False
Worksheets(sname).Delete
Application.DisplayAlerts = True
Application.DisplayAlerts = False
ActiveWorkbook.Close SaveChanges:=True
Application.DisplayAlerts = True
MsgBox WorksheetFunction.Text(Cells(2, 2), "ggge年")
Cells(2, 2) = Application.WorksheetFunction.Substitute(Cells(2, 2), "浅井", "藤本")
ActiveCell.FormulaR1C1 = "=SUM(RC[-2]:RC[-1])"
Select Case kcode
Case 174, 430
page = 4
Case 177, 427
page = 8
Case 171
page = 12
Case Else
page = 0
End Select
.AutoFilter Field:=1, Criteria1:="=" & tiku & "*" 'オートフィルタで抽出
Sub kyou3mae()
Dim tmp As Date
Dim tmp1 As String
tmp = DateAdd("yyyy", -3, Worksheets("開始").Cells(6, 2))
tmp1 = Year(tmp) & "/" & Month(tmp)
Worksheets("開始").Cells(6, 4) = tmp1
End Sub
Function kyoukara3nenmae(kyou As Date)
Dim tmp As Date
Dim tmp1 As String
tmp = DateAdd("yyyy", -3, kyou)
tmp1 = Year(tmp) & "/" & Month(tmp)
kyoukara3nenmae = tmp1
End Function
'別表1の計算
Select Case 社会保険控除後の給与
Case Is < 135417
給与所得控除後 = 54167
Case Is < 150000
給与所得控除後 = 社会保険控除後の給与 * 0.4
Case Is < 300000
給与所得控除後 = 社会保険控除後の給与 * 0.3 + 15000
Case Is < 550000
給与所得控除後 = 社会保険控除後の給与 * 0.2 + 45000
Case Is <= 833334
給与所得控除後 = 社会保険控除後の給与 * 0.1 + 100000
Case Else
給与所得控除後 = 社会保険控除後の給与 * 0.05 + 141667
End Select
'別表2の計算
'配偶・扶養者を検索(社員番号から)
社員番号 = Worksheets("給料明細VBA").Cells(3, 2)
lastrow = Worksheets("社員").Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To lastrow
If Worksheets("社員").Cells(i, 1) = 社員番号 Then
配偶者 = Worksheets("社員").Cells(i, 11)
扶養家族 = Worksheets("社員").Cells(i, 12)
Exit For
End If
Next
別表2 = (配偶者 + 扶養家族 + 1) * 31667
'別表3の計算
課税給与所得 = 給与所得控除後 - 別表2
Select Case 課税給与所得
Case Is < 162501
所得税 = 課税給与所得 * 0.05
Case Is < 275001
所得税 = 課税給与所得 * 0.1 - 8125
Case Is < 579167
所得税 = 課税給与所得 * 0.2 - 35625
Case Is < 750001
所得税 = 課税給与所得 * 0.23 - 53000
Case Is < 1500001
所得税 = 課税給与所得 * 0.33 - 128000
Case Else
所得税 = 課税給与所得 * 0.4 - 233000
End Select
MsgBox "資産計=" & Str(流動資産 + 固定資産) & vbCrLf & "負債計=" & Str(流動負債 + 資本) & vbCrLf & "流動資産=" & Str(流動資産)
ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True,IgnorePrintAreas:=False
Sub 伝票印刷()
Worksheets("売上伝票").PrintOut
End Sub
Sub 伝票印刷()
Worksheets("売上伝票").PrintPreview
End Sub
Sub プリンター名取得()
Dim プリンター名 As String
プリンター名 = Application.ActivePrinter
Cells(1, 1) = プリンター名
' Cells(2, 1) = プリンター名
End Sub
Sub プリンター切り替え()
Dim 通常使うプリンター As String
Dim 今回使うプリンター As String
通常使うプリンター = Application.ActivePrinter
今回使うプリンター = "Canon LBP3300 on Ne03:"
Application.ActivePrinter = 新プリンター名
End Sub
Sub 線引き画像A1()
With ActiveSheet.Shapes.AddLine(Range("A1").Left, Range("A1").Top + 10, Range("D1").Left + Range("D1").Width, Range("D1").Top + 10).Line
.ForeColor.RGB = vbRed
.Weight = 2
.EndArrowheadStyle = msoArrowheadTriangle
End With
End Sub
Sub 線引き画像cell()
With ActiveSheet.Shapes.AddLine(Cells(3, 1).Left, Cells(3, 1).Top + 10, Cells(3, 4).Left + Cells(3, 4).Width, Cells(3, 4).Top + 10).Line
.ForeColor.RGB = vbBlue
.Weight = 2
.EndArrowheadStyle = msoArrowheadTriangle
End With
End Sub
Sub 画像削除()
Dim 画像 As Shape
For Each 画像 In ActiveSheet.Shapes
'1-オートシェイプ 9-線
If 画像.Type = 9 Then
画像.Delete
End If
Next
End Sub
With ActiveSheet
For i = .Shapes.Count To 1 Step -1
If .Shapes(i).Type = msoTextBox Then .Shapes(i).Delete
Next i
End With
Dim ole As OLEObject
With ActiveSheet
.TextBoxes.Delete
End With
Dim tobj As Shape
For Each tobj In Worksheets("全員").Shapes
tobj.Delete
Next
Sub zennetaihi()
Dim kotosi As Long
Dim zennen As Long
Dim i As Long
Dim x As Long
For i = 2 To 13
If Cells(4, i) = "" Then
x = i - 1
Exit For
End If
Next
kotosi = 0
zennen = 0
For i = 2 To x
kotosi = kotosi + Cells(4, i)
zennen = zennen + Cells(3, i)
Next
Cells(5, 14) = kotosi / zennen
End Sub
Dim rc As Long
rc = MsgBox("削除してもよろしいか", vbYesNo + vbExclamation)
If rc = vbYes Then
MsgBox "削除されました", vbInformation
End If
Sub keisan()
On Error GoTo error
Cells(1, 1) = Cells(1, 2) / Cells(1, 3)
Exit Sub
error: MsgBox "エラーが発生しました"
End Sub
Sub keisan1()
On Error Resume Next
Cells(1, 1) = Cells(1, 2) / Cells(1, 3)
Cells(2, 1) = Cells(1, 2) * Cells(1, 3)
End Sub