投稿/コメントを表示します。

発展編1 フォローメールセミナー
発展編1 フォローメールセミナー　第9回

受講生さんの投稿

(投稿ID: 1603)

小川先生

ようやく宿題ができました。まる一日かかってしまいましたが、なんとか動きました。よろしくお願いいたします。
From 　岡田　まさこ
option explicit
Sub denpyo_sakusei_homework()
    denpyo_sakujo
    narabekae
    sheetsakusei
End Sub

'以下はそれぞれの部品です。

Sub denpyo_sakujo()            '部品１
    Dim ws As Worksheet
    
 Application.DisplayAlerts = False
 
    For Each ws In Worksheets
        If Left(ws.Name, 4) <> "main" Then
            ws.Delete
        End If
    Next
 Application.DisplayAlerts = True
 
End Sub

Sub narabekae()    '部品２
Dim wfm As Worksheet
Set wfm = Worksheets("main")

    wfm.Range("A2").FormulaR1C1 = "1"
    wfm.Range("A3").FormulaR1C1 = "2"
    wfm.Range("A4").FormulaR1C1 = "3"
    wfm.Range("A2:A4").AutoFill Destination:=Range("A2:A317")
    
    wfm.Sort.SortFields.Clear
    wfm.Sort.SortFields.Add Key:=Range("B2:B317"), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With wfm.Sort
        .SetRange Range("A1:G317")
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    


End Sub

Sub sheetsakusei()        '部品３
    Dim wfm As Worksheet
    Dim wto As Worksheet
    Dim cfm As Long
    Dim mx As Long
    Dim cto As Long
    
    Set wfm = Worksheets("main")
    Set wto = Worksheets("main1")
     mx = Range("B" & Rows.Count).End(xlUp).Row
    
    For cfm = 2 To mx
      
        If wfm.Range("B" & cfm).Value <> wfm.Range("B" & cfm - 1).Value Then
            If cfm > 2 Then
                keisen
            End If
       
            Worksheets("main1").Copy After:=Worksheets(Worksheets.Count)
             Set wto = ActiveSheet
            wto.Name = wfm.Range("B" & cfm).Value
         cto = 16
        End If
     
        If wto.Name = wfm.Range("B" & cfm).Value Then
            wto.Range("E" & cto).Value = wfm.Range("D" & cfm).Value
            wto.Range("F" & cto).Value = wfm.Range("E" & cfm).Value
            wto.Range("H" & cto).Value = wfm.Range("F" & cfm).Value
            wto.Range("J12").Value = wfm.Range("B" & cfm).Value
            
            wto.Range("B" & cto).Value = Right(Year(wfm.Range("C" & cfm).Value), 2)
            wto.Range("C" & cto).Value = Month(wfm.Range("C" & cfm).Value)
            wto.Range("D" & cto).Value = Day(wfm.Range("C" & cfm).Value)
            
            If wfm.Range("G" & cfm).Value > 0 Then
                wto.Range("I" & cto).Value = wfm.Range("G" & cfm).Value
            Else
                wto.Range("J" & cto).Value = wfm.Range("G" & cfm).Value
            End If
         
  
         
         Dim c As Range
         Set c = wto.Range("K" & cto)
            If cto = 16 Then
                c = c.Offset(0, -2).Value + c.Offset(0, -1).Value
            Else
                c = c.Offset(-1, 0).Value + c.Offset(0, -2).Value + c.Offset(0, -1).Value
            End If
            cto = cto + 1
        End If
      
    Next
    keisen
    
    Worksheets("main").Activate


    wfm.Sort.SortFields.Clear
    wfm.Sort.SortFields.Add Key:=Range("A1"), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With wfm.Sort
        .SetRange Range("A1:G317")
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

    Columns("A:A").ClearContents
    
End Sub

Sub keisen()          '部品４
    Dim kmx As Long
    kmx = Range("K" & Rows.Count).End(xlUp).Row

    With Range("B16:K" & kmx + 1)
        .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

2015/08/17 03:36