エクセルVBA全シートに差し込みマクロ構文
Sheets("震圧データ").Select
MsgBox "新規ブックに年月分けて" & vbCrLf & "震圧データを転記します、" & vbCrLf & "お待ちください。"
Dim c As Range
Dim i As Integer
Dim LastRow As Long
Dim NewSheetName As String, MatchFlag As Boolean
Application.ScreenUpdating = False
Workbooks.Add
With ThisWorkbook.Sheets("震圧データ")
For Each c In .Range(.Cells(4, "A"), .Cells(Rows.Count, "A").End(xlUp))
If NewSheetName <> Year(c.Value2) & "年" & Month(c.Value2) & "月" Then
NewSheetName = Year(c.Value2) & "年" & Month(c.Value2) & "月"
If c.Row - 2 > Sheets.Count Then
Worksheets.Add after:=Worksheets(Worksheets.Count)
Else
Sheets(c.Row - 2).Select
End If
ActiveSheet.Name = NewSheetName
Sheets(NewSheetName).Range("A1").Value = "年月日"
Sheets(NewSheetName).Range("B1").Value = "曜日"
Sheets(NewSheetName).Range("C1").Value = "A"
Sheets(NewSheetName).Range("D1").Value = "B"
Sheets(NewSheetName).Range("E1").Value = "C"
Sheets(NewSheetName).Range("F1").Value = "時間"
Sheets(NewSheetName).Range("G1").Value = "状態"
Sheets(NewSheetName).Range("I1").Value = "No.1"
Sheets(NewSheetName).Range("I2").Value = "記録者"
Sheets(NewSheetName).Range("I3").Value = "氏名:"
Sheets(NewSheetName).Range("I4").Value = "=IF(ISBLANK(A4),"""",DATEDIF("""",Today(),""Y"") & ""歳"")"
Sheets(NewSheetName).Range("I5").Value = "=""転載日"""
Sheets(NewSheetName).Range("I6").Value = "=TODAY()"
Sheets(NewSheetName).Range("I56").Value = "=IF(ISBLANK(A56),"""",""No.2"")"
Sheets(NewSheetName).Range("I57").Value = "=IF(ISBLANK(A56),"""",""記録者"")"
Sheets(NewSheetName).Range("I58").Value = "=IF(ISBLANK(A56),"""", ""氏名:"")"
Sheets(NewSheetName).Range("I59").Value = "=IF(ISBLANK(A56),"""",DATEDIF("""",Today(),""Y"") & ""歳"")"
Sheets(NewSheetName).Range("I60").Value = "=IF(ISBLANK(A56),"""",""転載日"")"
Sheets(NewSheetName).Range("I61").Value = "=IF(ISBLANK(A56),"""",TODAY())"
Sheets(NewSheetName).Range("I111").Value = "=IF(ISBLANK(A111),"""",""No.3"")"
Sheets(NewSheetName).Range("I112").Value = "=IF(ISBLANK(A111),"""",""記録者"")"
Sheets(NewSheetName).Range("I113").Value = "=IF(ISBLANK(A111),"""", ""氏名:"")"
Sheets(NewSheetName).Range("I114").Value = "=IF(ISBLANK(A111),"""",DATEDIF("""",Today(),""Y"") & ""歳"")"
Sheets(NewSheetName).Range("I115").Value = "=IF(ISBLANK(A111),"""",""転載日"")"
Sheets(NewSheetName).Range("I116").Value = "=IF(ISBLANK(A111),"""",TODAY())"
Sheets(NewSheetName).Range("I166").Value = "=IF(ISBLANK(A166),"""",""No.4"")"
Sheets(NewSheetName).Range("I167").Value = "=IF(ISBLANK(A166),"""",""記録者"")"
Sheets(NewSheetName).Range("I168").Value = "=IF(ISBLANK(A166),"""", ""氏名"")"
Sheets(NewSheetName).Range("I169").Value = "=IF(ISBLANK(A166),"""",DATEDIF("""",Today(),""Y"") & ""歳"")"
Sheets(NewSheetName).Range("I170").Value = "=IF(ISBLANK(A166),"""",""転載日"")"
Sheets(NewSheetName).Range("I171").Value = "=IF(ISBLANK(A166),"""",TODAY())"
Sheets(NewSheetName).Range("H1").Value = "提出済○"
Sheets(NewSheetName).Range("A57").Select
Range("I6,I61,I116").Select
Range("I6,I61,I116,I171").Select
Selection.NumberFormatLocal = "yyyy/m/d"
Columns("F:F").Select
Selection.NumberFormatLocal = "[$-409]h:mm AM/PM;@"
Range("G1").Select
With Selection
.HorizontalAlignment = xlCenter
End With
LastRow = Sheets(NewSheetName).Cells(Rows.Count, "A").End(xlUp).Row
Sheets(NewSheetName).Cells(LastRow + 1, "A").Resize(1, 8).Value = .Cells(c.Row, "A").Resize(1, 8).Value
Sheets(NewSheetName).Columns("A:I").EntireColumn.AutoFit
Next
新規ブック最終シートのみ適用できますが他の月別シートに適用できておりません
'↓どのような構文にしたら適用されるのでしょうか?ここからが質問です↓
If Sheets(NewSheetName).Range("A56") = "" Then
Range("I56:I171").Delete
Else
Sheets(NewSheetName).Range("A56").Value = "年月日"
Sheets(NewSheetName).Range("B56").Value = "曜日"
Sheets(NewSheetName).Range("C56").Value = "A"
Sheets(NewSheetName).Range("D56").Value = "B"
Sheets(NewSheetName).Range("E56").Value = "C"
Sheets(NewSheetName).Range("F56").Value = "時間"
Sheets(NewSheetName).Range("G56").Value = "状態"
End If 'ここまで! どなたかご教示お願いします
.Activate
End With
お礼
ありがとうございました。 temp のところは何も入っていませんでした。 引き続きご指導いただきたいのですがお願いします。
補足
早速のご指導有難うございます。 御指導の下記ですが、 C:\Users\実\AppData\Local\Temp エキスプローラ―で C:\Users\実 までは解りましたが \AppData\Local\Temp の部分が見当たりません。 私の探し方が悪いのでしょうか。 念のためにですが WINDOWS7でありますでしょうか。 再度ご指導いただけるとうれしいです。 よろしくお願いします。 調べてみましたらこのサイトのこと思いますが http://www.microsofttranslator.com/BV.aspx?ref=IE8Activity&a=http%3A%2F%2Fexcelmatters.com%2F2014%2F12%2F10%2Foffice-update-breaks-activex-controls%2F