Option Explicit
Dim wFm, wTo, wS, wA As Worksheet
Dim cMx, cCo, cTo As Long
Dim daHiduke As Date
Dim strNamae As String
Sub Zentai()
Set wFm = Worksheets("main")
Set wTo = Worksheets("main1")
cMx = wFm.Range("B" & wFm.Rows.Count).End(xlUp).Row
cCo = 2
Delete_Sheet
Tooshi_bangou
cCo = 2
NarabekaeB
cTo = 16
Sheet_Create_Kakikomi
cCo = 2
strNamae = ""
NarabekaeA
Sakujo_Tooshibangou
End Sub
Sub Delete_Sheet()
For Each wS In Worksheets
Application.DisplayAlerts = False
If wS.Name <> "main1" And wS.Name <> "main" Then
wS.Delete
End If
Next
Application.DisplayAlerts = True
End Sub
Sub Tooshi_bangou()
For cCo = 2 To cMx
wFm.Range("A" & cCo).Value = cCo - 1
Next
End Sub
Sub NarabekaeB()
With wFm
wFm.Sort.SortFields.Clear
wFm.Sort.SortFields.Add Key:=Range("B1"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With .Sort
.SetRange Range("A1:G" & cMx)
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End With
End Sub
Sub Sheet_Create_Kakikomi()
For cCo = 2 To cMx
If wFm.Range("B" & cCo).Value <> strNamae Then
If strNamae <> "" Then
wA.Range("H2").Value = wA.Range("K" & cTo - 1).Value
Keisen
End If
cTo = 16
strNamae = wFm.Range("B" & cCo).Value
wTo.Copy after:=wFm
Set wA = ActiveSheet
wA.Name = strNamae
wA.Range("J12").Value = strNamae
End If
With wA.Range("B" & cTo)
.Offset().Value = Year(wFm.Range("C" & cCo).Value) 'wA B
.Offset(, 1).Value = Month(wFm.Range("C" & cCo).Value) 'wA C
.Offset(, 2).Value = Day(wFm.Range("C" & cCo).Value) 'wA D
.Offset(, 3).Value = wFm.Range("D" & cCo).Value 'wA E
.Offset(, 4).Value = wFm.Range("E" & cCo).Value 'wA F
.Offset(, 6).Value = wFm.Range("F" & cCo).Value 'wA G
Select Case wFm.Range("G" & cCo).Value 'H
Case Is > 0
.Offset(, 7).Value = wFm.Range("G" & cCo).Value 'wA I
Case Is < 0
.Offset(, 8).Value = wFm.Range("G" & cCo).Value 'wA J
End Select
If cTo = 16 Then
.Offset(, 9).Value = .Offset(, 7).Value + .Offset(, 8).Value 'wA K= wA I+ wA J
Else
.Offset(, 9).Value = wA.Range("K" & cTo - 1).Value + .Offset(, 7).Value + .Offset(, 8).Value 'wA K=wA Kの一個上+wA I+ wA J
End If
End With
cTo = cTo + 1
Next
wA.Range("H2").Value = wA.Range("K" & cTo - 1).Value
Keisen
End Sub
Sub NarabekaeA()
With wFm
wFm.Sort.SortFields.Clear
wFm.Sort.SortFields.Add Key:=Range("A1"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With .Sort
.SetRange Range("A1:G" & cMx)
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End With
End Sub
Sub Sakujo_Tooshibangou()
wFm.Range("A2:A" & cMx).ClearContents
End Sub
Sub Keisen()
With wA.Range("B16:K" & cTo)
.Borders(xlDiagonalDown).LineStyle = xlNone
.Borders(xlDiagonalUp).LineStyle = xlNone
With .Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With .Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With .Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With .Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With .Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlHairline
End With
With .Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlHairline
End With
End With
End Sub
2017/10/14 01:43
小川慶一さんのコメント
(コメントID: 4977)
浦山大さん:
> 勉強を始めて2か月程でこんなに書けるようになるなんて思っていませんでした。感謝しています。
v(^^
実務でも成果でているようですね。 なので特に心配していませんが。。ひきつづきお楽しみください☆
Option Explicit
'↓以下2行、別の添削でお伝えしたとおり。都度データ型を指定しましょう!
Dim wFm, wTo, wS, wA As Worksheet
Dim cMx, cCo, cTo As Long
Dim daHiduke As Date
Dim strNamae As String
Sub Zentai()
Set wFm = Worksheets("main")
Set wTo = Worksheets("main1")
cMx = wFm.Range("B" & wFm.Rows.Count).End(xlUp).Row
cCo = 2
'インデント不正
Delete_Sheet
Tooshi_bangou
cCo = 2
'インデント不正
NarabekaeB
cTo = 16
'インデント不正
Sheet_Create_Kakikomi
cCo = 2
strNamae = ""
'インデント不正
NarabekaeA
Sakujo_Tooshibangou
End Sub
Sub Delete_Sheet()
'↓[*1], [*2] はきちんと入れ子になるように。
'↓インデント不正
For Each wS In Worksheets '[*1-1]
Application.DisplayAlerts = False '[*2-1]
If wS.Name <> "main1" And wS.Name <> "main" Then
wS.Delete
End If
Next '[*1-2]
Application.DisplayAlerts = True '[*2-2]
End Sub
Sub Tooshi_bangou()
For cCo = 2 To cMx
wFm.Range("A" & cCo).Value = cCo - 1
Next
End Sub
Sub NarabekaeB()
With wFm
wFm.Sort.SortFields.Clear
wFm.Sort.SortFields.Add Key:=Range("B1"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With .Sort
.SetRange Range("A1:G" & cMx)
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End With
End Sub
Sub Sheet_Create_Kakikomi()
For cCo = 2 To cMx
If wFm.Range("B" & cCo).Value <> strNamae Then
If strNamae <> "" Then
wA.Range("H2").Value = wA.Range("K" & cTo - 1).Value
Keisen
End If
cTo = 16
strNamae = wFm.Range("B" & cCo).Value
wTo.Copy after:=wFm
Set wA = ActiveSheet
wA.Name = strNamae
wA.Range("J12").Value = strNamae
End If
With wA.Range("B" & cTo)
.Offset().Value = Year(wFm.Range("C" & cCo).Value) 'wA B
.Offset(, 1).Value = Month(wFm.Range("C" & cCo).Value) 'wA C
.Offset(, 2).Value = Day(wFm.Range("C" & cCo).Value) 'wA D
.Offset(, 3).Value = wFm.Range("D" & cCo).Value 'wA E
.Offset(, 4).Value = wFm.Range("E" & cCo).Value 'wA F
.Offset(, 6).Value = wFm.Range("F" & cCo).Value 'wA G
Select Case wFm.Range("G" & cCo).Value 'H
Case Is > 0
.Offset(, 7).Value = wFm.Range("G" & cCo).Value 'wA I
Case Is < 0
.Offset(, 8).Value = wFm.Range("G" & cCo).Value 'wA J
End Select
If cTo = 16 Then
.Offset(, 9).Value = .Offset(, 7).Value + .Offset(, 8).Value 'wA K= wA I+ wA J
Else
.Offset(, 9).Value = wA.Range("K" & cTo - 1).Value + .Offset(, 7).Value + .Offset(, 8).Value 'wA K=wA Kの一個上+wA I+ wA J
End If
End With
cTo = cTo + 1
Next
wA.Range("H2").Value = wA.Range("K" & cTo - 1).Value
Keisen
End Sub
Sub NarabekaeA()
With wFm
wFm.Sort.SortFields.Clear
wFm.Sort.SortFields.Add Key:=Range("A1"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With .Sort
.SetRange Range("A1:G" & cMx)
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End With
End Sub
Sub Sakujo_Tooshibangou()
wFm.Range("A2:A" & cMx).ClearContents
End Sub
Sub Keisen()
With wA.Range("B16:K" & cTo)
.Borders(xlDiagonalDown).LineStyle = xlNone
.Borders(xlDiagonalUp).LineStyle = xlNone
With .Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With .Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With .Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With .Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With .Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlHairline
End With
With .Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlHairline
End With
End With
End Sub
浦山大さんの投稿
(投稿ID: 3507)
ノーヒントで罫線を引く部分まで作りました(通し番号が振られていない前提で作成)。
きちんと動きました…(大丈夫でしょうか?)。
一度、紙で印刷してみたら、A4用紙3枚分位になりました。
勉強を始めて2か月程でこんなに書けるようになるなんて思っていませんでした。感謝しています。
引き続き、よろしくお願いします(そろそろ、フォローメールセミナー30題にも取り掛かっていきたいと思っています)。
小川慶一さんのコメント
(コメントID: 4977)
> 勉強を始めて2か月程でこんなに書けるようになるなんて思っていませんでした。感謝しています。
v(^^
実務でも成果でているようですね。
なので特に心配していませんが。。ひきつづきお楽しみください☆