マクロ１
Option Explicit
'Function BookName(Optional Extension As Boolean = True) As String
'
' Dim strFileName As String ' ファイル名を取得する ユ－ザ－定義関数
'
' Application.Volatile
'
' strFileName = Application.ThisWorkbook.Name
'
' If Extension = True Then
' BookName = strFileName
' Else
'
' BookName = Left(strFileName, InStrRev(strFileName, ".", -1, vbTextCompare) - 1)
'' 表示するセルに関数 =BookName(FALSE) を入力
' End If
'
'End Function
Sub 回答1をファイル名にして保存()
' I3+回答+I4 をファイル名にする
Application.Dialogs(xlDialogSaveAs).Show Arg1:=Range("I3").Value & "回答" & Range("I4").Value, arg2:=12
'12はExcelブックです
End Sub
Sub SBCS2をファイル名にして保存()
' I5+SBCS をファイル名にする
Application.Dialogs(xlDialogSaveAs).Show Arg1:=Range("I5").Value & "SBCS", arg2:=12
'12はExcelブックです
End Sub
Sub 値に変換()
'
Dim gyo2 As Integer
gyo2 = Range("G2").Value '合計
Range("A8:Q" & gyo2 & "").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("D5").Select
End Sub
Sub 列RからXまで削除1()
'
Columns("R:X").Delete
End Sub
Sub 列KからXFDまでGからHまで削除2()
'
' 最初は列KからXFDまで、次にGからHまで削除
Columns("K:XFD").Delete
Columns("G:H").Delete
End Sub
Sub 注意事項から行削除する()
'
' 注意事項から特記事項手前まで削除する
Dim gyo4 As Integer
Dim gyo5 As Integer
gyo4 = Range("G4").Value
gyo5 = Range("G5").Value
Rows(gyo4 & ":" & gyo5).Delete
Range("D5").Select
End Sub
Sub 入力行関数E2J5設定()
Range("E2").Value = "行取得"
Range("E3").Value = "値に変換"
Range("F2").Value = "合計"
Range("F3").Value = "合計-1"
Range("F4").Value = "注意事項"
Range("F5").Value = "特記事項"
Range("H2").Value = "行"
Range("H3").Value = "行まで"
Range("H4").Value = "行"
Range("H5").Value = "行-1まで"
Range("G2").Select
ActiveCell.Formula = "=IF(COUNTIF(E1:E64,F2),MATCH(F2,E1:E64,0),"""")" '合計の入力行数
Range("G3").Select
ActiveCell.Formula = "=G2-1" '合計の入力行数-1 値に変換用
Range("G4").Select
ActiveCell.Formula = "=IF(COUNTIF(A1:A64,F4),MATCH(F4,A1:A64,0),"""")" ' 注意事項の入力行数 '特記事項の入力行数
Range("G5").Select
ActiveCell.Formula = "=IF(COUNTIF(A1:A64,F5),MATCH(F5,A1:A64,0)-1,"""")" '特記事項の入力行数
Range("I2").Select
ActiveCell.Formula = "=BookName(FALSE)" 'ユ－ザ定義関数でファイル名取得
Range("I3").Select
ActiveCell.Formula = "=MID(I2,1,8)" 'ファイル名左から8文字取得
Range("I4").Select
ActiveCell.Formula = "=MID(I2,9,LEN(I2))" 'ファイル名左から8文字除き右側取得
Range("I5").Select
ActiveCell.Formula = "=MID(I2,1,9)" 'ファイル名左から9文字取得
Range("J3").Value = "回答"
Range("J5").Value = "SBCS"
' E2からJ5まで色付け Macro
Range("E2:J5").Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Interior
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorAccent5
.TintAndShade = 0.599963377788629
.PatternTintAndShade = 0
End With
Range("D5").Select
End Sub
Sub 上書き保存()
'
ActiveWorkbook.Save
End Sub
Sub 納品時で行取得セルE2からJ5削除()
'
Range("E2:J5").Select
Selection.ClearContents
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
Selection.Borders(xlEdgeLeft).LineStyle = xlNone
Selection.Borders(xlEdgeTop).LineStyle = xlNone
Selection.Borders(xlEdgeBottom).LineStyle = xlNone
Selection.Borders(xlEdgeRight).LineStyle = xlNone
Selection.Borders(xlInsideVertical).LineStyle = xlNone
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
With Selection.Interior
.Pattern = xlNone
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Range("E5").Select
End Sub
Sub マクロボタン削除()
'
ActiveSheet.Shapes("Button 17").Select
Selection.Cut
ActiveSheet.Shapes("Button 15").Select
Selection.Cut
ActiveSheet.Shapes("Button 16").Select
Selection.Cut
End Sub
Sub 保存1回答()
上書き保存 'Excelマクロ有りで保存される
丸の時
値に変換
回答1をファイル名にして保存 'Excelマクロ無しで保存される
列RからXまで削除1
納品時で行取得セルE2からJ5削除
マクロボタン削除
再販制御O4P4最後に削除
上書き保存 'Excelマクロ無しで上書き保存される
Range("D5").Select
End Sub
Sub 保存2SBCS()
上書き保存 'Excelマクロ有りで保存される
値に変換
SBCS2をファイル名にして保存 'Excelマクロ無しで保存される
注意事項から行削除する
列KからXFDまでGからHまで削除2
納品時で行取得セルE2からJ5削除
マクロボタン削除
上書き保存 'Excelマクロ無しで上書き保存される
Range("D5").Select
End Sub
----------------------------------------------
----------------------------------------------
----------------------------------------------