レッスン-投稿一覧パソコン仕事５倍塾ポータル

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

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

加藤さんの投稿

(投稿ID: 4958)

予習のコードです。
メールを読むのはこれからですが、H列に合計を入れるところや罫線は、もっと効率の良い方法があるのではと楽しみです。

Sub day7yoshu()
    Delete_Sheets
    Dim shFm As Worksheet
    Dim InFm As Long
    Dim InFmMx As Long
    Dim st As String
    Dim shTo As Worksheet
    Dim dt As Date
    Dim gyo As Long
    Set shFm = Worksheets("main")
    InFmMx = shFm.Range("B65536").End(xlUp).Row
    For InFm = 2 To InFmMx
        If st <> shFm.Range("B" & InFm).Value Then
            Debug.Print shFm.Range("B" & InFm).Value
            st = shFm.Range("B" & InFm).Value
            Sheets("main1").Copy After:=Sheets(2)
            Set shTo = ActiveSheet
            shTo.Name = st
            gyo = 16
        End If
        If shFm.Range("G" & InFm).Value < 0 Then
            '貸方に負の数が入らないよう、右辺はマイナスとした。
            shTo.Range("J" & gyo).Value = -shFm.Range("G" & InFm).Value
        Else
            shTo.Range("I" & gyo).Value = shFm.Range("G" & InFm).Value
        End If
        dt = shFm.Range("C" & InFm).Value
        shTo.Range("H" & gyo).Value = shFm.Range("F" & InFm).Value
        shTo.Range("E" & gyo).Value = shFm.Range("D" & InFm).Value
        shTo.Range("F" & gyo).Value = shFm.Range("E" & InFm).Value
        shTo.Range("B" & gyo).Value = Right(Year(dt), 2)
        shTo.Range("C" & gyo).Value = Month(dt)
        shTo.Range("D" & gyo).Value = Day(dt)
        If gyo = 16 Then
            shTo.Range("K" & gyo).Value = shTo.Range("I" & gyo).Value - shTo.Range("J" & gyo).Value
        ElseIf gyo > 16 Then
            shTo.Range("K" & gyo).Value = shTo.Range("I" & gyo).Value - shTo.Range("J" & gyo).Value + shTo.Range("K" & gyo - 1).Value
        End If
        shTo.Range("B" & gyo & ":K" & gyo).Select
        With Selection.Borders(xlEdgeTop)
            .LineStyle = xlContinuous
            .Weight = xlThin
        End With
        With Selection.Borders(xlEdgeBottom)
            .LineStyle = xlContinuous
            .Weight = xlThin
        End With
        gyo = gyo + 1
    Next
End Sub

Sub Delete_Sheets()
    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

2020/12/26 10:42

小川慶一さんのコメント

(コメントID: 7001)

加藤さん:

おはようございます。
楽しまれているようで何よりです。

罫線については、罫線を引く処理を実行する回数をどう減らすか？というのがポイントです。
このサンプルデータくらいならまだしもですが、たとえば「10,000件のデータがあり、作るシートは10枚」とかになると、罫線を引く処理を10,000回やることになるのか、それとも10回で済むのか？というのは、パフォーマンス上の大きな差になります。

2020/12/26 18:39

受講生さんのコメント

(コメントID: 7002)

罫線が入ったからよしとしておりましたが、ご指摘の課題がありますね。リライトしてみます。

小川慶一さん:

> 加藤さん:
>
> おはようございます。
> 楽しまれているようで何よりです。
>
> 罫線については、罫線を引く処理を実行する回数をどう減らすか？というのがポイントです。
> このサンプルデータくらいならまだしもですが、たとえば「10,000件のデータがあり、作るシートは10枚」とかになると、罫線を引く処理を10,000回やることになるのか、それとも10回で済むのか？というのは、パフォーマンス上の大きな差になります。
>

2020/12/27 19:29

小川慶一さんのコメント

(コメントID: 7003)

受講生さん:

予習ですので、適当に頭に汗をかいたのであれば、先に進んで解説を読んでください。その方が学習効率は高いかと。

2020/12/27 19:55

加藤さんのコメント

(コメントID: 7004)

必要な全セルの入力完了後に、まとめて罫線を追加するようにコードを修正してみました。メールを読んでみます。

Sub day7yoshu2()
    Delete_Sheets
    Dim shFm As Worksheet
    Dim InFm As Long
    Dim InFmMx As Long
    Dim st As String
    Dim shTo As Worksheet
    Dim dt As Date
    Dim gyo As Long
    Set shFm = Worksheets("main")
    InFmMx = shFm.Range("B65536").End(xlUp).Row
    For InFm = 2 To InFmMx
        If st <> shFm.Range("B" & InFm).Value Then
            Debug.Print shFm.Range("B" & InFm).Value
            st = shFm.Range("B" & InFm).Value
            Sheets("main1").Copy After:=Sheets(2)
            Set shTo = ActiveSheet
            shTo.Name = st
            gyo = 16
        End If
        If shFm.Range("G" & InFm).Value < 0 Then
            '貸方に負の数が入らないよう、右辺はマイナスとした。
            shTo.Range("J" & gyo).Value = -shFm.Range("G" & InFm).Value
        Else
            shTo.Range("I" & gyo).Value = shFm.Range("G" & InFm).Value
        End If
        dt = shFm.Range("C" & InFm).Value
        shTo.Range("H" & gyo).Value = shFm.Range("F" & InFm).Value
        shTo.Range("E" & gyo).Value = shFm.Range("D" & InFm).Value
        shTo.Range("F" & gyo).Value = shFm.Range("E" & InFm).Value
        shTo.Range("B" & gyo).Value = Right(Year(dt), 2)
        shTo.Range("C" & gyo).Value = Month(dt)
        shTo.Range("D" & gyo).Value = Day(dt)
        If gyo = 16 Then
            shTo.Range("K" & gyo).Value = shTo.Range("I" & gyo).Value - shTo.Range("J" & gyo).Value
        ElseIf gyo > 16 Then
            shTo.Range("K" & gyo).Value = shTo.Range("I" & gyo).Value - shTo.Range("J" & gyo).Value + shTo.Range("K" & gyo - 1).Value
        End If
        gyo = gyo + 1
        '全セルの入力完了後に、まとめて罫線を追加するようにした。
        shTo.Range("B16" & ":K" & gyo - 1).Select
        With Selection.Borders(xlEdgeTop)
            .LineStyle = xlContinuous
            .Weight = xlThin
        End With
        With Selection.Borders(xlEdgeBottom)
            .LineStyle = xlContinuous
            .Weight = xlThin
        End With
    Next
End Sub

Sub Delete_Sheets()
    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

2020/12/27 20:00

加藤さんのコメント

(コメントID: 7007)

シートへの転記が終わる都度罫線を追加するには、解説のとおり、新たにシートを追加する直前に罫線追加のプロシージャを入れる必要がありますね。
先に投稿したコードでは、「1行転記する毎の罫線追加」となっておりました。勉強になりました。

2020/12/28 00:35

小川慶一さんのコメント

(コメントID: 7005)

加藤さん:

おはようございます。

それなりにコミットして検討してから解説を読むというのが王道パターンです。
あと、「ループの初回は何もしない、ループを抜けた瞬間に処理をする」という型は、使えるようになると汎用性が高くて便利です。型としてモノにしてください。

2020/12/28 17:52