受講生 さん:

おはようございます。

> でも、自分でも出来ることがわかったので、大変満足しております。

こういう課題をやりとげると、自己効力感高まりますよね v(^^*

添削を返送します☆

Option Explicit
'全体に、とてもよく書けています！ v(^^*
'変数名で英単語一語のものを使うのは(VBの予約語とかぶるかもしれないので)やや危険。
'dim no as long は、僕なら、他の名称にするかもしれません。
Sub narabikae_1()
    Dim ws As Worksheet
    Dim no As Long
    Dim lastRow As Long
    
    Set ws = Worksheets("main")
    lastRow = ws.Range("B65536").End(xlUp).Row
    '↓autofillを使うことも試してみてください
    For no = 2 To lastRow
        ws.Range("A" & no).Value = no - 1
    Next
        ws.Range("A1").Value = "NO" '←インデント不正
        
    ws.Sort.SortFields.Clear
    ws.Sort.SortFields.Add Key:=Range("B2:B" & lastRow), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ws.Sort
        .SetRange Range("A1:G317")
        .Header = xlYes
        .Apply
    End With

End Sub
Sub narabikae_2()
    Dim ws As Worksheet
    Dim no As Long
    Dim lastRow As Long
    
    Set ws = Worksheets("main")
    lastRow = ws.Range("B65536").End(xlUp).Row
'    For no = 2 To lastRow
'        ws.Range("A" & no).Value = no - 1
'    Next
'        ws.Range("A1").Value = "NO"
        
    ws.Sort.SortFields.Clear
    ws.Sort.SortFields.Add Key:=Range("A2:A" & lastRow), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ws.Sort
        .SetRange Range("A1:G" & lastRow)
        .Header = xlYes
        .Apply
    End With

End Sub
Sub denpyofukusei()
    Dim ws As Worksheet
    For Each ws In Worksheets
        If Left(ws.Name, "main") <> 4 Then
            '↓インデント過剰
                Sheets("main1").Copy After:=Sheets(2)
                Sheets("main1 (2)").Name = Worksheets("main").Range("B2").Value
        End If
    Next
End Sub
Sub denpyosakusei()
    DeleteSheets
    narabikae_1 '←より可読性の高い名前にしましょう。具体的に何をするのでしょうか？
    Dim shFm As Worksheet
    Dim meishou As String
    Dim cGyo As Long
    Dim lastRow As Long
    Dim shTo As Worksheet
    Dim saki As Long
    Dim dt As Date
    
    Set shFm = Worksheets("main")
    lastRow = shFm.Range("B65536").End(xlUp).Row
    
    For cGyo = 2 To lastRow
        If meishou <> shFm.Range("B" & cGyo).Value Then
            If cGyo > 2 Then
                keisen
            End If
            meishou = shFm.Range("B" & cGyo).Value
            Sheets("main1").Copy After:=Sheets(2)
            Set shTo = ActiveSheet
            shTo.Name = meishou
            saki = 16
        End If
        shTo.Range("H" & saki).Value = shFm.Range("F" & cGyo).Value
        shTo.Range("F" & saki).Value = shFm.Range("E" & cGyo).Value
        shTo.Range("E" & saki).Value = shFm.Range("D" & cGyo).Value
        If shFm.Range("G" & cGyo).Value > 0 Then
            shTo.Range("I" & saki).Value = shFm.Range("G" & cGyo).Value
        Else
            shTo.Range("J" & saki).Value = shFm.Range("G" & cGyo).Value
        End If
'        keisen
        dt = shFm.Range("C" & cGyo).Value
        '↓format関数を使うことも試してみてください
        shTo.Range("B" & saki).Value = Right(Year(dt), 2)
        shTo.Range("C" & saki).Value = Month(dt)
        shTo.Range("D" & saki).Value = Day(dt)
        
        shTo.Range("K" & saki).Value = shTo.Range("K" & saki - 1).Value + shTo.Range("I" & saki).Value + shTo.Range("J" & saki).Value
             
            
        saki = saki + 1
    Next
    keisen
    shFm.Activate
    narabikae_2 '←より可読性の高い名前にしましょう。具体的に何をするのでしょうか？
End Sub
Sub DeleteSheets()
    Dim sh As Worksheet
    Application.DisplayAlerts = False
    For Each sh In Worksheets
        If Left(sh.Name, 4) <> "main" Then
            sh.Delete
        End If
    Next
    Application.DisplayAlerts = True
End Sub
Sub keisen()
    Dim lastRow As Long
    
    lastRow = Range("B65536").End(xlUp).Row
    '↓select, selection という言葉がなくなるまでブラッシュアップを！
    Range("B16:K" & lastRow + 1).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
End Sub

> いつもお世話になっております。
> なんとか作成出来ましたが、まだまだ時間がかかっております。でも、自分でも出来ることがわかったので、大変満足しております。作成したファイルを送らせていただきます。お手数ですが、よろしくお願いいたします。

2018/08/30 17:47