オンライン講座 質問と回答

無料・有料のオンライン講座で寄せられたメッセージの一部を紹介致します。

[11491]発展編1 フォローメールセミナー 第11回

2019-07-01 14:38:26 小川慶一さんからの投稿です。

受講生の方から、添削依頼を受けました。
以下のものです。

Option Explicit
Dim wFm As Worksheet
Dim Ireru As String
Dim Mx As Long

Public Sub WsDelete()
    Dim wd As Worksheet
    Application.DisplayAlerts = False
    For Each wd In Worksheets
        If Left(wd.Name, 4) <> "main" Then
            wd.Delete
        End If
    Next
    Application.DisplayAlerts = True
End Sub

Private Sub Bangou()
    wFm.Range("A2").FormulaR1C1 = "1"
    wFm.Range("A2:A317").DataSeries Rowcol:=xlColumns, _
    Type:=xlLinear, Date:=xlDay, _
    Step:=1, Trend:=False
End Sub

Private Sub Narabe()
    wFm.Sort.SortFields.Clear
    wFm.Sort.SortFields.Add Key:=wFm.Range(Ireru), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With wFm.Sort
        .SetRange wFm.Range("A1:" & "G" & wFm.Range("G65536").End(xlUp).Row)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

End Sub
Private Sub Keisen()
    Mx = Range("K65536").End(xlUp).Row
    With Range("B16:K" & Mx)
        .Borders(xlDiagonalUp).LineStyle = xlNone
        .Borders(xlDiagonalDown).LineStyle = xlNone
        .Borders(xlEdgeLeft).LineStyle = xlContinuous
        .Borders(xlEdgeLeft).Weight = xlThin
        .Borders(xlEdgeTop).LineStyle = xlContinuous
        .Borders(xlEdgeTop).Weight = xlThin
        .Borders(xlEdgeBottom).LineStyle = xlContinuous
        .Borders(xlEdgeBottom).Weight = xlThin
        .Borders(xlEdgeRight).LineStyle = xlContinuous
        .Borders(xlEdgeRight).Weight = xlThin
        .Borders(xlInsideVertical).LineStyle = xlContinuous
        .Borders(xlInsideVertical).Weight = xlHairline
        .Borders(xlInsideHorizontal).LineStyle = xlContinuous
        .Borders(xlInsideHorizontal).Weight = xlHairline
    End With
End Sub
Private Sub P_hani()
    ActiveWindow.View = xlPageBreakPreview
    ActiveSheet.VPageBreaks(1).DragOff Direction:=xlToRight, RegionIndex:=1
    ActiveWindow.View = xlNormalView
End Sub

Private Sub Daimei()
    Application.PrintCommunication = False
    With ActiveSheet.PageSetup
        .PrintTitleRows = ""
        .PrintTitleColumns = ""
    End With
    Application.PrintCommunication = True
    ActiveSheet.PageSetup.PrintArea = ""
    Application.PrintCommunication = False
    With ActiveSheet.PageSetup

        .CenterHeader = "&F"


        .CenterFooter = "&P / &N ページ"

        .LeftMargin = Application.InchesToPoints(0.748031496062992)
        .RightMargin = Application.InchesToPoints(0.748031496062992)
        .TopMargin = Application.InchesToPoints(0.984251968503937)
        .BottomMargin = Application.InchesToPoints(0.984251968503937)
        .HeaderMargin = Application.InchesToPoints(0.511811023622047)
        .FooterMargin = Application.InchesToPoints(0.511811023622047)
        .PrintHeadings = False
        .PrintGridlines = False
        .PrintComments = xlPrintNoComments
        .CenterHorizontally = False
        .CenterVertically = False
        .Orientation = xlPortrait
        .Draft = False
        .PaperSize = xlPaperA4
        .FirstPageNumber = xlAutomatic
        .Order = xlDownThenOver
        .BlackAndWhite = False
        .Zoom = 100
        .PrintErrors = xlPrintErrorsDisplayed
        .OddAndEvenPagesHeaderFooter = False
        .DifferentFirstPageHeaderFooter = False
        .ScaleWithDocHeaderFooter = True
        .AlignMarginsHeaderFooter = False
            End With
    Application.PrintCommunication = True
    
End Sub
Private Sub Tyousei()
    Keisen
    Daimei
    P_hani
    
End Sub

Public Sub Denpyo()
    Application.ScreenUpdating = False
    Dim wTo As Worksheet
    Dim lnMoto As Long
    Dim lnSaki As Long
    Dim dHiduke As Date
    
    Set wFm = Worksheets("main")
    WsDelete
    wFm.Activate
    Bangou
    Ireru = "B2:" & "B" & wFm.Range("B65536").End(xlUp).Row
    Narabe
       
    For lnMoto = 2 To wFm.Range("B65536").End(xlUp).Row
        If wFm.Range("B" & lnMoto).Value <> wFm.Range("B" & lnMoto - 1).Value Then
            
            If lnMoto > 2 Then
                Tyousei
            End If
            
            lnSaki = 16
            Sheets("main1").Copy After:=Sheets(2)
            Set wTo = Worksheets(3)
            wTo.Name = wFm.Range("B" & lnMoto).Value
        End If
        dHiduke = wFm.Range("C" & lnMoto).Value
        wTo.Range("B" & lnSaki).Value = Left(Year(dHiduke), 2)
        wTo.Range("C" & lnSaki).Value = Month(dHiduke)
        wTo.Range("D" & lnSaki).Value = Day(dHiduke)
        wTo.Range("E" & lnSaki).Value = wFm.Range("D" & lnMoto).Value
        wTo.Range("F" & lnSaki).Value = wFm.Range("E" & lnMoto).Value
        wTo.Range("H" & lnSaki).Value = wFm.Range("F" & lnMoto).Value
        If wFm.Range("G" & lnMoto).Value > 0 Then
            wTo.Range("I" & lnSaki).Value = wFm.Range("G" & lnMoto).Value
        Else
            wTo.Range("J" & lnSaki).Value = wFm.Range("G" & lnMoto).Value
        End If
        If lnMoto > 2 Then
            wTo.Range("K" & lnSaki).Value = wFm.Range("G" & lnMoto).Value + wTo.Range("K" & lnSaki - 1).Value
        Else
            wTo.Range("K" & lnSaki).Value = wFm.Range("G" & lnMoto).Value
        End If
        lnSaki = lnSaki + 1
    Next
    
    Tyousei
    
    Ireru = "A2:" & "A" & wFm.Range("A65536").End(xlUp).Row
    Narabe
    
    wFm.Range("A2:" & "A" & wFm.Range("A65536").End(xlUp).Row).ClearContents
    wFm.Activate
    Application.ScreenUpdating = True
End Sub

[ 続きを読む ]  返信件数:1件  [ 動画を見る] 

[11474]発展編1 フォローメールセミナー 第11回

2019-06-24 13:55:59 小川慶一さんからの投稿です。

とある受講生の方から、添削依頼をいただきました。
以下に添削を示します。

まずは、いただいたコード。

Option Explicit
Dim wFm As Worksheet
Dim Ireru As String
Dim Mx As Long

Sub WsDelete()
    Dim wd As Worksheet
    Application.DisplayAlerts = False
    For Each wd In Worksheets
        If Left(wd.Name, 4) <> "main" Then
            wd.Delete
        End If
    Next
    Application.DisplayAlerts = True
End Sub

Sub Bangou()
    wFm.Range("A2").FormulaR1C1 = "1"
    wFm.Range("A2:A317").DataSeries Rowcol:=xlColumns, _
    Type:=xlLinear, Date:=xlDay, _
    Step:=1, Trend:=False
End Sub

Sub Narabe()
    wFm.Sort.SortFields.Clear
    wFm.Sort.SortFields.Add Key:=Range(Ireru), _
        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 Keisen()
    Mx = Range("K65536").End(xlUp).Row
    Range("B16:K" & Mx).Borders(xlDiagonalDown).LineStyle = xlNone
    Range("B16:K" & Mx).Borders(xlDiagonalUp).LineStyle = xlNone
    With Range("B16:K" & Mx)
        .Borders(xlEdgeLeft).LineStyle = xlContinuous
        .Borders(xlEdgeLeft).Weight = xlThin
        .Borders(xlEdgeTop).LineStyle = xlContinuous
        .Borders(xlEdgeTop).Weight = xlThin
        .Borders(xlEdgeBottom).LineStyle = xlContinuous
        .Borders(xlEdgeBottom).Weight = xlThin
        .Borders(xlEdgeRight).LineStyle = xlContinuous
        .Borders(xlEdgeRight).Weight = xlThin
        .Borders(xlInsideVertical).LineStyle = xlContinuous
        .Borders(xlInsideVertical).Weight = xlHairline
        .Borders(xlInsideHorizontal).LineStyle = xlContinuous
        .Borders(xlInsideHorizontal).Weight = xlHairline
    End With
End Sub
Sub Phani()
    ActiveWindow.View = xlPageBreakPreview
    ActiveSheet.VPageBreaks(1).DragOff Direction:=xlToRight, RegionIndex:=1
    ActiveWindow.View = xlNormalView
End Sub

Sub Daimei()
    Application.PrintCommunication = False
    With ActiveSheet.PageSetup
        .PrintTitleRows = ""
        .PrintTitleColumns = ""
    End With
    Application.PrintCommunication = True
    ActiveSheet.PageSetup.PrintArea = ""
    Application.PrintCommunication = False
    With ActiveSheet.PageSetup
        .LeftHeader = ""
        .CenterHeader = "&F"
        .RightHeader = ""
        .LeftFooter = ""
        .CenterFooter = "&P / &N ページ"
        .RightFooter = ""
        .LeftMargin = Application.InchesToPoints(0.748031496062992)
        .RightMargin = Application.InchesToPoints(0.748031496062992)
        .TopMargin = Application.InchesToPoints(0.984251968503937)
        .BottomMargin = Application.InchesToPoints(0.984251968503937)
        .HeaderMargin = Application.InchesToPoints(0.511811023622047)
        .FooterMargin = Application.InchesToPoints(0.511811023622047)
        .PrintHeadings = False
        .PrintGridlines = False
        .PrintComments = xlPrintNoComments
        .CenterHorizontally = False
        .CenterVertically = False
        .Orientation = xlPortrait
        .Draft = False
        .PaperSize = xlPaperA4
        .FirstPageNumber = xlAutomatic
        .Order = xlDownThenOver
        .BlackAndWhite = False
        .Zoom = 100
        .PrintErrors = xlPrintErrorsDisplayed
        .OddAndEvenPagesHeaderFooter = False
        .DifferentFirstPageHeaderFooter = False
        .ScaleWithDocHeaderFooter = True
        .AlignMarginsHeaderFooter = False
        .EvenPage.LeftHeader.Text = ""
        .EvenPage.CenterHeader.Text = ""
        .EvenPage.RightHeader.Text = ""
        .EvenPage.LeftFooter.Text = ""
        .EvenPage.CenterFooter.Text = ""
        .EvenPage.RightFooter.Text = ""
        .FirstPage.LeftHeader.Text = ""
        .FirstPage.CenterHeader.Text = ""
        .FirstPage.RightHeader.Text = ""
        .FirstPage.LeftFooter.Text = ""
        .FirstPage.CenterFooter.Text = ""
        .FirstPage.RightFooter.Text = ""
    End With
    Application.PrintCommunication = True
    
End Sub

Sub Denpyo()
    Dim wTo As Worksheet
    Dim Moto As Long
    Dim Saki As Long
    Dim Hiduke As Long
    
    Set wFm = Worksheets("main")
    WsDelete
    wFm.Activate
    Bangou
    Ireru = "B2:B317"
    Narabe
       
    For Moto = 2 To wFm.Range("B65536").End(xlUp).Row
        If wFm.Range("B" & Moto).Value <> wFm.Range("B" & Moto - 1).Value Then
            
            If Moto > 2 Then
                Keisen
                Daimei
                Phani
            End If
            
            Saki = 16
            Sheets("main1").Copy After:=Sheets(2)
            Set wTo = Worksheets(3)
            wTo.Name = wFm.Range("B" & Moto).Value
        End If
        Hiduke = wFm.Range("C" & Moto).Value
        wTo.Range("B" & Saki).Value = Left(Year(Hiduke), 2)
        wTo.Range("C" & Saki).Value = Month(Hiduke)
        wTo.Range("D" & Saki).Value = Day(Hiduke)
        wTo.Range("E" & Saki).Value = wFm.Range("D" & Moto).Value
        wTo.Range("F" & Saki).Value = wFm.Range("E" & Moto).Value
        wTo.Range("H" & Saki).Value = wFm.Range("F" & Moto).Value
        If wFm.Range("G" & Moto).Value > 0 Then
            wTo.Range("I" & Saki).Value = wFm.Range("G" & Moto).Value
        Else
            wTo.Range("J" & Saki).Value = wFm.Range("G" & Moto).Value
        End If
        If Moto > 2 Then
            wTo.Range("K" & Saki).Value = wFm.Range("G" & Moto).Value + wTo.Range("K" & Saki - 1).Value
        Else
            wTo.Range("K" & Saki).Value = wFm.Range("G" & Moto).Value
        End If
        Saki = Saki + 1
    Next
    
    Keisen
    Daimei
    Phani
    
    Ireru = "A2:A317"
    Narabe
    
    wFm.Activate
    wFm.Range("A2:A317").ClearContents
End Sub


そして、以下は、添削内容。

'データ数の増減に耐えられるプログラムにしましょう
'実際にデータ数を増減させて動作確認されると良いかと思います
'「317」という検索キーワードでコード内を検索もしてください
'あと、以下では書いていませんが、SubプロシージャにPublic, Privateキーワードも入れたいですね。
Option Explicit
Dim wFm As Worksheet
Dim Ireru As String
Dim Mx As Long

'↓Excellent v(^^*
Sub WsDelete()
    Dim wd As Worksheet
    Application.DisplayAlerts = False
    For Each wd In Worksheets
        If Left(wd.Name, 4) <> "main" Then
            wd.Delete
        End If
    Next
    Application.DisplayAlerts = True
End Sub

'↓Excellent v(^^*
Sub Bangou()
    wFm.Range("A2").FormulaR1C1 = "1"
    wFm.Range("A2:A317").DataSeries Rowcol:=xlColumns, _
    Type:=xlLinear, Date:=xlDay, _
    Step:=1, Trend:=False
End Sub

Sub Narabe()
    wFm.Sort.SortFields.Clear
    wFm.Sort.SortFields.Add Key:=Range(Ireru), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With wFm.Sort
        .SetRange Range("A1:G317") 'データ数可変でもOKになるようになおしましょう
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

End Sub
Sub Keisen()
    Mx = Range("K65536").End(xlUp).Row
    '[3] 以下、 With Range("B16:K" & Mx) ... End With で [4] までをくくれるのでは?と。
    '以下の要領。
    'With Range("B16:K" & Mx)
    '    .Borders(xlDiagonalDown).LineStyle = xlNone
    '    .Borders(xlDiagonalUp).LineStyle = xlNone
    '    .Borders(xlEdgeLeft).LineStyle = xlContinuous
    '    .Borders(xlEdgeLeft).Weight = xlThin
    '    .Borders(xlEdgeTop).LineStyle = xlContinuous
    '    .Borders(xlEdgeTop).Weight = xlThin
    '    .Borders(xlEdgeBottom).LineStyle = xlContinuous
    '    .Borders(xlEdgeBottom).Weight = xlThin
    '    .Borders(xlEdgeRight).LineStyle = xlContinuous
    '    .Borders(xlEdgeRight).Weight = xlThin
    '    .Borders(xlInsideVertical).LineStyle = xlContinuous
    '    .Borders(xlInsideVertical).Weight = xlHairline
    '    .Borders(xlInsideHorizontal).LineStyle = xlContinuous
    '    .Borders(xlInsideHorizontal).Weight = xlHairline
    'End With
    
    Range("B16:K" & Mx).Borders(xlDiagonalDown).LineStyle = xlNone
    Range("B16:K" & Mx).Borders(xlDiagonalUp).LineStyle = xlNone
    With Range("B16:K" & Mx)
        .Borders(xlEdgeLeft).LineStyle = xlContinuous
        .Borders(xlEdgeLeft).Weight = xlThin
        .Borders(xlEdgeTop).LineStyle = xlContinuous
        .Borders(xlEdgeTop).Weight = xlThin
        .Borders(xlEdgeBottom).LineStyle = xlContinuous
        .Borders(xlEdgeBottom).Weight = xlThin
        .Borders(xlEdgeRight).LineStyle = xlContinuous
        .Borders(xlEdgeRight).Weight = xlThin
        .Borders(xlInsideVertical).LineStyle = xlContinuous
        .Borders(xlInsideVertical).Weight = xlHairline
        .Borders(xlInsideHorizontal).LineStyle = xlContinuous
        .Borders(xlInsideHorizontal).Weight = xlHairline
    End With
End Sub
Sub Phani()
    'Sub Print_Area() のように、間にアンダーバーを入れた名前にするのもありです。VBのキーワードには、アンダーバーが入ったものはないので。
    'アンダーバーを間に入れるなら、簡単な英単語の組み合わせでも安全(VBのキーワードとかぶる心配はない)です
    ActiveWindow.View = xlPageBreakPreview
    ActiveSheet.VPageBreaks(1).DragOff Direction:=xlToRight, RegionIndex:=1
    ActiveWindow.View = xlNormalView
End Sub

Sub Daimei()
    '不要と思しきものがかなりありますね。ご自身で設定したものを見出し、それ以外は積極的に削除を!
    Application.PrintCommunication = False
    With ActiveSheet.PageSetup
        .PrintTitleRows = ""
        .PrintTitleColumns = ""
    End With
    Application.PrintCommunication = True
    ActiveSheet.PageSetup.PrintArea = ""
    Application.PrintCommunication = False
    With ActiveSheet.PageSetup
        .LeftHeader = ""
        .CenterHeader = "&F"
        .RightHeader = ""
        .LeftFooter = ""
        .CenterFooter = "&P / &N ページ"
        .RightFooter = ""
        .LeftMargin = Application.InchesToPoints(0.748031496062992)
        .RightMargin = Application.InchesToPoints(0.748031496062992)
        .TopMargin = Application.InchesToPoints(0.984251968503937)
        .BottomMargin = Application.InchesToPoints(0.984251968503937)
        .HeaderMargin = Application.InchesToPoints(0.511811023622047)
        .FooterMargin = Application.InchesToPoints(0.511811023622047)
        .PrintHeadings = False
        .PrintGridlines = False
        .PrintComments = xlPrintNoComments
        .CenterHorizontally = False
        .CenterVertically = False
        .Orientation = xlPortrait
        .Draft = False
        .PaperSize = xlPaperA4
        .FirstPageNumber = xlAutomatic
        .Order = xlDownThenOver
        .BlackAndWhite = False
        .Zoom = 100
        .PrintErrors = xlPrintErrorsDisplayed
        .OddAndEvenPagesHeaderFooter = False
        .DifferentFirstPageHeaderFooter = False
        .ScaleWithDocHeaderFooter = True
        .AlignMarginsHeaderFooter = False
        .EvenPage.LeftHeader.Text = ""
        .EvenPage.CenterHeader.Text = ""
        .EvenPage.RightHeader.Text = ""
        .EvenPage.LeftFooter.Text = ""
        .EvenPage.CenterFooter.Text = ""
        .EvenPage.RightFooter.Text = ""
        .FirstPage.LeftHeader.Text = ""
        .FirstPage.CenterHeader.Text = ""
        .FirstPage.RightHeader.Text = ""
        .FirstPage.LeftFooter.Text = ""
        .FirstPage.CenterFooter.Text = ""
        .FirstPage.RightFooter.Text = ""
    End With
    Application.PrintCommunication = True
    
End Sub

Sub Denpyo()
    'Application.ScreenUpdating = False '高速化と画面チラツキ防止のため、画面更新を停止
    '↓Moto, Saki, Hidukeは、ハンガリアン記法にしてもいいかも。たとえば、 sMoto, sSaki, dHidukeという変数名で。
    Dim wTo As Worksheet
    Dim Moto As Long
    Dim Saki As Long
    Dim Hiduke As Long
    
    Set wFm = Worksheets("main")
    WsDelete
    wFm.Activate
    Bangou
    Ireru = "B2:B317" '←データ数可変でも動くようになおしたいですね。
    Narabe
       
    For Moto = 2 To wFm.Range("B65536").End(xlUp).Row 'エクセル2007以降のファイル形式で、かつ、データ数が65566件以上ある場合には注意!
        If wFm.Range("B" & Moto).Value <> wFm.Range("B" & Moto - 1).Value Then
            
            If Moto > 2 Then
                '[1]↓Keisen, Daimei, Phani を実行するプロシージャを何か用意してもよいですね。そうすると、[2]での記述も一行で済みます
                Keisen
                Daimei
                Phani
            End If
            
            Saki = 16
            Sheets("main1").Copy After:=Sheets(2)
            Set wTo = Worksheets(3)
            wTo.Name = wFm.Range("B" & Moto).Value
        End If
        Hiduke = wFm.Range("C" & Moto).Value
        '以下3つは、Format関数を使うこともできます。たとえば直下の行の右辺は、 Format(Fiduke,"yy")
        wTo.Range("B" & Saki).Value = Left(Year(Hiduke), 2)
        wTo.Range("C" & Saki).Value = Month(Hiduke)
        wTo.Range("D" & Saki).Value = Day(Hiduke)
        wTo.Range("E" & Saki).Value = wFm.Range("D" & Moto).Value
        wTo.Range("F" & Saki).Value = wFm.Range("E" & Moto).Value
        wTo.Range("H" & Saki).Value = wFm.Range("F" & Moto).Value
        If wFm.Range("G" & Moto).Value > 0 Then
            wTo.Range("I" & Saki).Value = wFm.Range("G" & Moto).Value
        Else
            wTo.Range("J" & Saki).Value = wFm.Range("G" & Moto).Value
        End If
        If Moto > 2 Then
            wTo.Range("K" & Saki).Value = wFm.Range("G" & Moto).Value + wTo.Range("K" & Saki - 1).Value
        Else
            wTo.Range("K" & Saki).Value = wFm.Range("G" & Moto).Value
        End If
        Saki = Saki + 1
    Next
    
    '[2]
    Keisen
    Daimei
    Phani
    
    Ireru = "A2:A317"
    Narabe
    
    wFm.Activate
    wFm.Range("A2:A317").ClearContents 'データ数可変でもOKになるようになおしましょう
    Application.ScreenUpdating = True '画面更新を再開
End Sub

[ 続きを読む ]  返信件数:1件  [ 動画を見る] 

[11142]発展編1 フォローメールセミナー 第11回

2019-02-13 05:06:07 A.Sさんからの投稿です。

小川先生

いつもお世話になっております。
第9回に引き続き、第11回の宿題を提出させていただきます。
お忙しいところ大変恐れ入りますが、添削の程、どうぞよろしくお願い致します。

Sub CreateDenpyo()
    DeleteSheets
    Template_Setup
    Numbering
    Narabekae_Torihikisaki
    Denpyosheet_Set
    Narabekae_No
    NumberingDelete
End Sub

'「main1」シートのページ設定をするマクロ
Private Sub Template_Setup()
    With Sheets("main1").PageSetup
        .PrintArea = "" '印刷範囲の解除
        .CenterHeader = "&A" 'ヘッダーに「シート名」を挿入
        .CenterFooter = "&P" 'フッターに「ページ番号」を挿入
    End With
    Range("A1").Select
End Sub

'「main」シートのA列に番号を振るマクロ
Private Sub Numbering()
    Dim ln As Long
    Dim lnMx As Long
    Dim ws As Worksheet
    Set ws = Worksheets("main")
    ws.Range("A1").Value = "No."
    lnMx = ws.Range("B" & Rows.Count).End(xlUp).Row
    For ln = 2 To lnMx
        ws.Range("A" & ln).Value = ln
    Next
End Sub

'「main」シートのA列のデータを全て削除するマクロ
Private Sub NumberingDelete()
    Dim lnMx As Long
    Dim ws As Worksheet
    Set ws = Worksheets("main")
    lnMx = ws.Range("A" & Rows.Count).End(xlUp).Row
    ws.Range("A1:A" & lnMx).ClearContents
End Sub

'「main」シートのB列を昇順に並び替えるマクロ
Private Sub Narabekae_Torihikisaki()
    With Worksheets("main").Sort
    .SortFields.Clear
    .SortFields.Add Key:=Range("B2:B317"), _
    SortOn:=xlSortOnValues, _
    Order:=xlAscending, _
    DataOption:=xlSortNormal
    .SetRange Range("A1:G317")
    .Header = xlYes
    .Apply
    End With
End Sub

'「main」シートのA列を昇順に並び替えるマクロ
Private Sub Narabekae_No()
    With Worksheets("main").Sort
    .SortFields.Clear
    .SortFields.Add Key:=Range("A2:A317"), _
    SortOn:=xlSortOnValues, _
    Order:=xlAscending, _
    DataOption:=xlSortNormal
    .SetRange Range("A1:G317")
    .Header = xlYes
    .Apply
    End With
End Sub

'取引先毎の伝票シートを作成するマクロ
Private Sub Denpyosheet_Set()
    DeleteSheets
    Dim lnFm As Long
    Dim lnFmMx As Long
    Dim lnTo As Long
    Dim st As String
    Dim wsFm As Worksheet
    Dim wsTo As Worksheet
    Dim dt As Date
    Set wsFm = Worksheets("main")
    lnFmMx = wsFm.Range("B" & Rows.Count).End(xlUp).Row
    For lnFm = 2 To lnFmMx
        If st <> wsFm.Range("B" & lnFm).Value Then
            If lnFm > 2 Then
                Keisen
            End If
            st = wsFm.Range("B" & lnFm).Value
            Sheets("main1").Copy After:=Sheets(Worksheets.Count)
            Set wsTo = ActiveSheet
            wsTo.Name = st
            lnTo = 16
        End If
        wsTo.Range("E" & lnTo).Value = wsFm.Range("D" & lnFm).Value
        wsTo.Range("F" & lnTo).Value = wsFm.Range("E" & lnFm).Value
        wsTo.Range("H" & lnTo).Value = wsFm.Range("F" & lnFm).Value
        If wsFm.Range("G" & lnFm).Value > 0 Then
            wsTo.Range("I" & lnTo).Value = wsFm.Range("G" & lnFm).Value
        Else
            wsTo.Range("J" & lnTo).Value = wsFm.Range("G" & lnFm).Value
        End If
        If lnTo = 16 Then
            wsTo.Range("K" & lnTo).Value = wsFm.Range("G" & lnFm).Value
        Else
            wsTo.Range("K" & lnTo).Value = wsFm.Range("G" & lnFm).Value + wsTo.Range("K" & lnTo).Offset(-1).Value
        End If
        dt = wsFm.Range("C" & lnFm).Value
        wsTo.Range("B" & lnTo).Value = Format(dt, "yy")
        wsTo.Range("C" & lnTo).Value = Format(dt, "m")
        wsTo.Range("D" & lnTo).Value = Format(dt, "d")
        lnTo = lnTo + 1
    Next
    Keisen
End Sub

'取引先名称シートを削除するマクロ
Public Sub DeleteSheets()
    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

'取引先名称シートに罫線を作成するマクロ
Private Sub Keisen()
    Dim lnMx As Long
    lnMx = Range("B" & Rows.Count).End(xlUp).Row
    With Range("B16:K" & lnMx + 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 = xlThin
        End With
        With .Borders(xlInsideHorizontal)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlHairline
        End With
    End With
End Sub

[ 続きを読む ]  返信件数:5件  [ 動画を見る] 

[10630]発展編1 フォローメールセミナー 第11回

2018-10-06 06:40:04 わかやまさんからの投稿です。

小川様 

添削よろしくお願いいたします。

Sub ikkini()
    sort1
    hontai
    sort2
End Sub


Sub sort1()
    Dim cSaigo As Long
    cSaigo = Worksheets("main").Range("B" & Rows.Count).End(xlUp).Row
    Worksheets("main").Sort.SortFields.Clear
    Worksheets("main").Sort.SortFields.Add Key:=Worksheets("main").Range("B2:B" & cSaigo), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal  'ワークシートを指定しました
    With Worksheets("main").Sort
        .SetRange Range("A1:G" & cSaigo)
        .Header = xlYes
        .Apply
    End With
    Worksheets("main").Range("A1").Value = "No."
    Worksheets("main").Range("A2").Value = 1
    Worksheets("main").Range("A2").AutoFill Destination:=Worksheets("main").Range("A2:A" & cSaigo), Type:=xlLinearTrend 'ワークシートを指定しました
    heda 'ヘッダーとフッターの設定
End Sub


Sub sort2()
    Dim cSaigo As Long
    cSaigo = Worksheets("main").Range("B" & Rows.Count).End(xlUp).Row
    Worksheets("main").Sort.SortFields.Clear
    Worksheets("main").Sort.SortFields.Add Key:=Worksheets("main").Range("A2:A" & cSaigo), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal 'ワークシートを指定しました
    With Worksheets("main").Sort
        .SetRange Range("A1:G" & cSaigo)
        .Header = xlYes
        .Apply
    End With
End Sub


Sub syokyo()
    Dim ws As Worksheet
    For Each ws In Worksheets
        Application.DisplayAlerts = False
        If Left(ws.Name, 4) <> "main" Then 'Left関数を用いました!
            ws.Delete
        End If
        Application.DisplayAlerts = True
    Next
End Sub


Sub hontai()
    syokyo
    Dim cGyo As Long
    Dim cSaigo As Long
    Dim wsMain As Worksheet
    Dim wsNow As Worksheet
    Dim sGyosya As String
    Dim dDate As Date
    Dim cSaki As Long
    Set wsMain = Worksheets("main")
    cSaigo = wsMain.Range("B" & Rows.Count).End(xlUp).Row
    For cGyo = 2 To cSaigo
        If sGyosya <> wsMain.Range("B" & cGyo).Value Then
            If cGyo > 2 Then
                keisen2
            End If
            Sheets("main1").Copy After:=Sheets(Worksheets.Count)
            Sheets("main1 (2)").Name = wsMain.Range("B" & cGyo).Value
            Set wsNow = ActiveSheet
            sGyosya = wsNow.Name
            cSaki = 16
        End If
        wsNow.Range("F2").Value = wsNow.Name
        wsNow.Range("H" & cSaki).Value = wsMain.Range("F" & cGyo).Value
        wsNow.Range("F" & cSaki).Value = wsMain.Range("E" & cGyo).Value
        wsNow.Range("E" & cSaki).Value = wsMain.Range("D" & cGyo).Value
        dDate = wsMain.Range("C" & cGyo).Value
        wsNow.Range("B" & cSaki).Value = Format(dDate, "yy")
        wsNow.Range("C" & cSaki).Value = Format(dDate, "mm")
        wsNow.Range("D" & cSaki).Value = Format(dDate, "dd")
        If wsMain.Range("G" & cGyo) > 0 Then
            wsNow.Range("I" & cSaki).Value = wsMain.Range("G" & cGyo).Value
        ElseIf wsMain.Range("G" & cGyo) < 0 Then
            wsNow.Range("J" & cSaki).Value = wsMain.Range("G" & cGyo).Value
        End If
        If cSaki = 16 Then
            wsNow.Range("K" & cSaki) = wsMain.Range("G" & cGyo).Value
        Else
            wsNow.Range("K" & cSaki) = wsMain.Range("G" & cGyo).Value + wsNow.Range("K" & cSaki - 1)
        End If
        cSaki = cSaki + 1
    Next
    keisen2
End Sub


Sub keisen2() 'ネットで調べ、シンプルにしました。同じ動作にはなっております。
    Dim cSaigo As Long
    Dim wsNow As Worksheet
    Set wsNow = ActiveSheet
    cSaigo = wsNow.Range("B" & Rows.Count).End(xlUp).Row
    wsNow.Range("B16:K" & cSaigo).Borders.LineStyle = xlContinuous
End Sub


Sub heda()
    With Worksheets("main1").PageSetup
        .CenterHeader = "伝票"
        .CenterFooter = Date
    End With
End Sub

[ 続きを読む ]  返信件数:3件  [ 動画を見る] 

[10472]発展編1 フォローメールセミナー 第11回

2018-08-21 21:32:27 マメコトさんからの投稿です。

お世話になっております。

Sub Denpyou()
    Call Sort_First
    Call Delete_Sheets
    Call Create_Denpyou
    Call Sort_End
End Sub

という伝票作成マクロの、Create_Denpyouの中にCreate_Keisenを作り、そのCreate_Keisenの最後に印刷に関するコードを書きました。
・・・とは言え、マクロの記録のどこを削れば良いのかわかりませんでした。
Private Sub Create_Keisen()

    Dim nGyou As Long
    
    nGyou = Range("E" & Rows.Count).End(xlUp).Row
    
    Range("B16:K" & nGyou).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
    
    Application.PrintCommunication = False
    With ActiveSheet.PageSetup
        .PrintTitleRows = ":"
        .PrintTitleColumns = ""
    End With
    With ActiveSheet.PageSetup
        .LeftHeader = ""
        .CenterHeader = ""
        .RightHeader = ""
        .LeftFooter = ""
        .CenterFooter = ""
        .RightFooter = ""
        .LeftMargin = Application.InchesToPoints(0.78740157480315)
        .RightMargin = Application.InchesToPoints(0.78740157480315)
        .TopMargin = Application.InchesToPoints(0.984251968503937)
        .BottomMargin = Application.InchesToPoints(0.984251968503937)
        .HeaderMargin = Application.InchesToPoints(0.511811023622047)
        .FooterMargin = Application.InchesToPoints(0.511811023622047)
        .PrintHeadings = False
        .PrintGridlines = False
        .PrintComments = xlPrintNoComments
        .PrintQuality = 600
        .CenterHorizontally = True
        .CenterVertically = False
        .Orientation = xlLandscape
        .Draft = False
        .PaperSize = xlPaperA4
        .FirstPageNumber = xlAutomatic
        .Order = xlDownThenOver
        .BlackAndWhite = False
        .Zoom = False
        .FitToPagesWide = 1
        .FitToPagesTall = 10
        .PrintErrors = xlPrintErrorsDisplayed
        .OddAndEvenPagesHeaderFooter = False
        .DifferentFirstPageHeaderFooter = False
        .ScaleWithDocHeaderFooter = True
        .AlignMarginsHeaderFooter = False
        .EvenPage.LeftHeader.Text = ""
        .EvenPage.CenterHeader.Text = ""
        .EvenPage.RightHeader.Text = ""
        .EvenPage.LeftFooter.Text = ""
        .EvenPage.CenterFooter.Text = ""
        .EvenPage.RightFooter.Text = ""
        .FirstPage.LeftHeader.Text = ""
        .FirstPage.CenterHeader.Text = ""
        .FirstPage.RightHeader.Text = ""
        .FirstPage.LeftFooter.Text = ""
        .FirstPage.CenterFooter.Text = ""
        .FirstPage.RightFooter.Text = ""
    End With
    ActiveSheet.PageSetup.PrintArea = ""
    Application.PrintCommunication = True
End Sub

やはりひとつひとつ意味を調べるべきなのでしょうか。

[ 続きを読む ]  返信件数:1件  [ 動画を見る] 

[9857]発展編1 フォローメールセミナー 第11回

2018-04-27 16:08:14 受講生さんからの投稿です。

第11回セミナーの宿題を提出いたします。
ご査収下さい。

[ 続きを読む ]  返信件数:5件  [ 動画を見る] 

[9482]発展編1 フォローメールセミナー 第11回

2018-02-26 19:27:12 受講生さんからの投稿です。

小川先生

お世話になっております。
(2/25に返信をいただいた受講生です。)

先日指摘頂いた内容を修正した上で、
課題の内容を追加しました。

ヘッダーに関しては、”取引先名称”
フッダーに関しては、”シートNo”
上記のような設定内容としました。

添削の方、よろしくお願いします。

Option Explicit

Dim moto As Long    '転記元行番号
Dim saki As Long    '転記先行番号
Public sheet_num As Long   'フッダー用のシート番号

Sub main()  'メインの実行プロシージャ
    Delete_Voucher
    num_asg
    name_sort
    Create_Voucher
    num_sort
    num_del
End Sub

Sub Delete_Voucher() 'シート削除用("main","mai1"を除く)

    Dim w As Worksheet

    For Each w In Worksheets
        Select Case w.Name
            Case "main", "main1"
            Case Else
                Application.DisplayAlerts = False
                w.Delete
                Application.DisplayAlerts = True
        End Select
    Next
End Sub

Sub num_asg()   'Noの割り振り

    Worksheets("main").Select
    Range("A1").Value = "No"
     
    Dim LastNum As Long
    LastNum = Range("B" & Rows.Count).End(xlUp).Row
     
    Range("A2").Value = "1"    'AutoFillによる番号の割り当て
    Range("A2").AutoFill Destination:=Range("A2:A" & LastNum), Type:=xlFillSeries
End Sub
 
Sub name_sort()     '名称で並べ替え
 
    Worksheets("main").Select
    ActiveWorkbook.Worksheets("main").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("main").Sort.SortFields.Add _
                                    Key:=Range("B2:B" & Range("B" & Rows.Count).End(xlUp).Row), _
                                    SortOn:=xlSortOnValues, _
                                    Order:=xlAscending, _
                                    DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("main").Sort
        .SetRange Range("A1:G" & Range("G" & Rows.Count).End(xlUp).Row)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
End Sub
 
Sub Create_Voucher() 'シート作成用
     
    Dim LastNum As Long
    LastNum = Range("B" & Rows.Count).End(xlUp).Row
    Dim name_bk As String
    Dim shFm As Worksheet
    Set shFm = Worksheets("main")

    sheet_num = 1
     
    For moto = 2 To LastNum
                                     
        If (moto = 2) Or (name_bk <> shFm.Range("B" & moto).Value) Then
            If moto <> 2 Then
                Call keisen                                              '取引先名称が異なった時に、罫線を作成し
                Call header_footer                                       'ヘッダーフッダーの作成を行う
            End If
            saki = 16                                                    '転送先の行番号を初期化する
            name_bk = shFm.Range("B" & moto).Value                       '最初の行読み込み時、もしくは、取引先名称が異なった時に、シートを作成する
            Worksheets("main1").Copy After:=Worksheets(Worksheets.Count)
            Worksheets(Worksheets.Count).Name = name_bk
        End If
         
        Call tenki_kingaku
        saki = saki + 1
    Next
    Call keisen                                                  '最終行書込み後、罫線を引く
    Call header_footer                                           'ヘッダーフッダーの作成を行う
End Sub
  
Sub tenki_kingaku()  'データの転記
 
    Dim shFm As Worksheet
    Set shFm = Worksheets("main")
 
    Worksheets(Worksheets.Count).Range("B" & saki).Value = Format((shFm.Range("C" & moto).Value), "yy")
    Worksheets(Worksheets.Count).Range("C" & saki).Value = Format(shFm.Range("C" & moto).Value, "m")
    Worksheets(Worksheets.Count).Range("D" & saki).Value = Format(shFm.Range("C" & moto).Value, "d")
    Worksheets(Worksheets.Count).Range("E" & saki).Value = shFm.Range("D" & moto).Value
    Worksheets(Worksheets.Count).Range("F" & saki).Value = shFm.Range("E" & moto).Value
    Worksheets(Worksheets.Count).Range("H" & saki).Value = shFm.Range("F" & moto).Value
    
    If shFm.Range("G" & moto).Value > 0 Then          '貸方・借方の転記
        Worksheets(Worksheets.Count).Range("I" & saki).Value = shFm.Range("G" & moto).Value
    Else
        Worksheets(Worksheets.Count).Range("J" & saki).Value = shFm.Range("G" & moto).Value
    End If
     
    If saki = 16 Then                                 '残高の記載
        Worksheets(Worksheets.Count).Range("K" & saki).Value = shFm.Range("G" & moto).Value
    Else
        Worksheets(Worksheets.Count).Range("K" & saki).Value = Worksheets(Worksheets.Count).Range("K" & saki - 1).Value + shFm.Range("G" & moto).Value
    End If
End Sub
 
Sub keisen()  '罫線作成

      With Range("B16:K" & Range("K" & Rows.Count).End(xlUp).Row)
        .Borders(xlEdgeLeft).Weight = xlThin
        .Borders(xlEdgeTop).Weight = xlThin
        .Borders(xlEdgeBottom).Weight = xlThin
        .Borders(xlEdgeRight).Weight = xlThin
        .Borders(xlInsideVertical).Weight = xlThin
        .Borders(xlInsideHorizontal).Weight = xlThin
      End With
End Sub

Sub header_footer()   '印刷範囲、ヘッダー、フッダーの設定(追加分)
    
    With ActiveSheet.PageSetup
    .PrintArea = "A1:L" & Range("K" & Rows.Count).End(xlUp).Row + 1 '印刷範囲の設定
    .CenterHorizontally = True
    .CenterHeader = "&""明朝""&A"                                   'ヘッダーに取引先名称
    .CenterFooter = "&""MS P明朝,標準""&12" & Str(sheet_num)     'フッダーにシート番号
    End With
    
    sheet_num = sheet_num + 1
    
End Sub

Sub num_sort()     'Noで並べ替え
 
    Worksheets("main").Select
    Columns("A:G").Select
    ActiveWorkbook.Worksheets("main").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("main").Sort.SortFields.Add _
                                    Key:=Range("A2:A" & Range("A" & Rows.Count).End(xlUp).Row), _
                                    SortOn:=xlSortOnValues, _
                                    Order:=xlAscending, _
                                    DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("main").Sort
        .SetRange Range("A1:G" & Range("G" & Rows.Count).End(xlUp).Row)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
End Sub

Sub num_del()     'A列のNoを削除(追加分)

    Range("A1:A" & Range("A" & Rows.Count).End(xlUp).Row).Clear
End Sub

[ 続きを読む ]  返信件数:1件  [ 動画を見る] 

[9325]発展編1 フォローメールセミナー 第11回

2018-01-04 23:51:48 受講生さんからの投稿です。

小川先生
大変お世話になっております。
添付セミナーNo.11の宿題を送ります。
下記のところでエラーが出ました。
——————————————
Sub number_return_delete()
Dim lastrow As Long
lastrow = Worksheets(“main”).Range(“b65536”).End(xlUp).Row
Worksheets(“main”).Range(“A1:G” & lastrow).Sort _
Key1:=Range(“a1”), _
Order1:=xlAscending, _
Header:=xlYes
——————————
何回も確認をしましたが、エラーの原因究明をうまくできませんでした。
大変お手数ですが、マクロの確認修正をよろしくお願いいたします。
どうぞ、お力を貸していただけますようにお願いします。

[ 続きを読む ]  返信件数:1件  [ 動画を見る] 

[9029]発展編1 フォローメールセミナー 第11回

2017-10-10 13:40:18 受講生さんからの投稿です。

小川先生、いつもお世話になっております。

【動画9】のフィードバック(コメント:9020)を踏まえ、
追加要件も実装しました。
印刷範囲をクリアするコード(.PrintArea = “”)が必要だと
わかるまで時間がかかりました(汗)
添削の程、よろしくお願い致します。

Option Explicit
Dim wOg As Worksheet    '原本シート(main)の変数
Dim wDa As Worksheet    'データシート(main1)の変数
Dim cDaMxRow As Long    'データシート(main1)の最終行を示す変数
Dim cMkRow As Long      '新規シートの行を指定する変数
Dim Skey As String      'データシートの並び替えを指定する変数
    
Public Sub Homework()
    Set wOg = Worksheets("main1")
    Set wDa = Worksheets("main")
    cDaMxRow = wDa.Range("B" & Rows.Count).End(xlUp).Row
    
    DelDenpyou
    BangouFuri
    
    Skey = "B1"
    Narabikae

    CreateDenpyou

    Skey = "A1"
    Narabikae

    DeleteBangou
End Sub

Public Sub DelDenpyou()
    Dim Wsh As Worksheet
    Application.DisplayAlerts = False
    For Each Wsh In Worksheets
        With Wsh
            If .Name <> "main" And .Name <> "main1" Then  '←if文に変更
                .delete
            End If
        End With
    Next Wsh
    Application.DisplayAlerts = True
    PrintSet '[★]追加要件
End Sub

Sub PrintSet() '[★]追加要件
    If wOg.Name = "main" Then
        With wOg.PageSetup
            .LeftHeader = "&A"
            .CenterHeader = ""
            .RightHeader = ""
            .LeftFooter = ""
            .CenterFooter = ""
            .RightFooter = "[作成日]&D"
        End With
    Else
        With ActiveSheet.PageSetup
            .PrintArea = ""
            .FitToPagesWide = 1
            .FitToPagesTall = 1
        End With
    End If
End Sub

Public Sub BangouFuri()
    Dim cNt As Long
    With wDa.Range("A1")
        .Offset(0, 0).Value = "No."
        For cNt = 1 To 3
            .Offset(cNt, 0).Value = cNt
        Next cNt
    End With
    wDa.Range("A2:A4").AutoFill Destination:=wDa.Range("A2:A" & cDaMxRow)
End Sub

Public Sub CreateDenpyou()
    Dim wMk As Worksheet
    Dim cDaRow As Long
    Dim sClnt As String
    Dim dTda As Date
    For cDaRow = 2 To cDaMxRow
        If sClnt <> wDa.Range("B" & cDaRow).Value Then
            If cDaRow > 2 Then
                Keisen
                PrintSet '[★]追加要件
            End If
            wOg.Copy after:=Worksheets(Worksheets.Count)
            sClnt = wDa.Range("B" & cDaRow).Value
            Set wMk = ActiveSheet
            wMk.Name = sClnt
            cMkRow = 16
        End If
        dTda = wDa.Range("C" & cMkRow).Value
        With wMk
            .Range("B" & cMkRow).Value = Mid(Year(dTda), 3)
            .Range("C" & cMkRow).Value = Month(dTda)
            .Range("D" & cMkRow).Value = Day(dTda)
            .Range("E" & cMkRow).Value = wDa.Range("D" & cMkRow).Value
            .Range("F" & cMkRow).Value = wDa.Range("E" & cMkRow).Value
            .Range("H" & cMkRow).Value = wDa.Range("F" & cMkRow).Value
            If wDa.Range("G" & cMkRow).Value > 0 Then
                .Range("I" & cMkRow).Value = wDa.Range("G" & cMkRow).Value
            Else
                .Range("J" & cMkRow).Value = wDa.Range("G" & cMkRow).Value
            End If
            .Range("K" & cMkRow).Value = WorksheetFunction.Sum(.Range("I16:J" & cMkRow))
        End With
        cMkRow = cMkRow + 1
    Next cDaRow
    Keisen
End Sub

Public Sub Keisen()
    With Range("B16:K" & cMkRow)
        With .Borders(xlEdgeLeft)
            .LineStyle = xlContinuous
            .Weight = xlThin
        End With
        With .Borders(xlEdgeTop)
            .LineStyle = xlContinuous
            .Weight = xlThin
        End With
        With .Borders(xlEdgeBottom)
            .LineStyle = xlContinuous
            .Weight = xlThin
        End With
        With .Borders(xlEdgeRight)
            .LineStyle = xlContinuous
            .Weight = xlThin
        End With
        With .Borders(xlInsideVertical)
            .LineStyle = xlContinuous
            .Weight = xlThin
        End With
        With .Borders(xlInsideHorizontal)
            .LineStyle = xlContinuous
            .Weight = xlHairline
        End With
    End With
End Sub

Public Sub Narabikae()
    With wDa
        With .Sort
            With .SortFields
                .Clear
                .Add Key:=wDa.Range(Skey), Order:=xlAscending
            End With
            .SetRange wDa.Range("A1:G" & cDaMxRow)
            .Header = xlYes
            .Apply
        End With
    End With
End Sub

Public Sub DeleteBangou()
    With wDa
        .Activate '←ここに記載し、1回のみの処理に変更
        .Range("A1").Activate
        .Range("A1").EntireColumn.ClearContents
    End With
End Sub

[ 続きを読む ]  返信件数:1件  [ 動画を見る] 

[7542]発展編1 フォローメールセミナー 第11回

2017-01-21 23:29:13 受講生さんからの投稿です。

小川先生、いつもお世話になっております。
印刷範囲とヘッダーを追加した伝票作成マクロの作成を致しました。

モジュールレベルの変数とプロシージャレベルの変数をうまく使い分けることがまだ難しいように感じました。
添削の程、何卒よろしくお願いします。

Option Explicit
Dim Mn As Worksheet
Dim Mn1 As Worksheet
Dim Amax As Long
 
Sub Denpyo_making()
    Set Mn = Worksheets("main")
    Set Mn1 = Worksheets("main1")
    Amax = Mn.Range("B65536").End(xlUp).Row
    
    Deletesheets1
    Numbering
    Narabikae
    sheets_making
    Narabikae2
    syuseiH_C

End Sub

Sub Deletesheets1()
    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 Numbering()

    Mn.Range("A2").Value = 1
    Mn.Range("A2").AutoFill _
        Mn.Range("A2:A" & Amax), xlFillSeries

End Sub

Sub Narabikae()
    Mn.Sort.SortFields.Clear
    Mn.Sort.SortFields.Add Key:= _
        Range("B1"), Order:=xlAscending
    With Mn.Sort
        .SetRange Range("A1:G" & Amax)
        .Header = xlYes
        .Apply
    End With
End Sub

Sub sheets_making()
    Dim Namae As String
    Dim gyo As Long
    Dim Nws As Worksheet
    Dim dt As Date '日付
    Dim saki As Long
    
    For gyo = 2 To Amax
        If Namae <> Mn.Range("B" & gyo).Value Then
            If gyo > 2 Then
                keisen_making '最初だけ罫線回避
            End If
            Namae = Mn.Range("B" & gyo).Value
            Sheets("main1").Copy After:=Sheets(Sheets.Count)
            Sheets("main1 (2)").Select
            Sheets("main1 (2)").Name = Namae
            Set Nws = Worksheets(Namae)
            saki = 16
        End If

        dt = Mn.Range("C" & gyo).Value
        Nws.Range("B" & saki).Value = Right(Year(dt), 2)
        Nws.Range("C" & saki).Value = Month(dt)
        Nws.Range("D" & saki).Value = Day(dt)
        Nws.Range("F2").Value = Mn.Range("B" & gyo).Value
        Nws.Range("E" & saki).Value = Mn.Range("D" & gyo).Value
        Nws.Range("F" & saki).Value = Mn.Range("E" & gyo).Value
        Nws.Range("H" & saki).Value = Mn.Range("F" & gyo).Value
        
        If Mn.Range("G" & gyo).Value > 0 Then
            Nws.Range("I" & saki).Value = Mn.Range("G" & gyo).Value
        Else
            Nws.Range("J" & saki).Value = Mn.Range("G" & gyo).Value
        End If
        Nws.Range("K" & saki).Value = Nws.Range("I" & saki).Value + Nws.Range("J" & saki).Value
        saki = saki + 1
    Next
    keisen_making '最後の会社のシートに罫線つける
End Sub

 Sub keisen_making()
    Dim cNewmax
    cNewmax = Range("B65536").End(xlUp).Row
    Range("B16:K" & cNewmax).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
    Selection.Borders(xlInsideVertical).LineStyle = xlNone
    Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
End Sub

Sub Narabikae2()
    Mn.Sort.SortFields.Clear
    Mn.Sort.SortFields.Add Key:= _
        Range("C1"), Order:=xlAscending
    With Mn.Sort
        .SetRange Range("A2:G" & Amax)
        .Header = xlYes
        .Apply
    End With
    Mn.Range("A2").Value = ""
    Mn.Range("A2").AutoFill _
        Mn.Range("A2:A" & Amax), xlFillSeries
    
End Sub
    
Sub syuseiH_C()
    Dim cNewmax As Long
    Dim c As Long
    Dim Wh As Worksheet
    cNewmax = Range("B65536").End(xlUp).Row
    
    For Each Wh In Worksheets
        If Left(Wh.Name, 4) <> "main" Then
            With Wh.PageSetup
                .LeftHeader = Wh.Name
                .RightHeader = "&D"
                .Zoom = 100
                .PrintErrors = xlPrintErrorsDisplayed
                .OddAndEvenPagesHeaderFooter = False
                .DifferentFirstPageHeaderFooter = False
                .ScaleWithDocHeaderFooter = True
                .AlignMarginsHeaderFooter = False
            End With
            ActiveSheet.PageSetup.PrintArea = "A1:K" & cNewmax
        End If
    Next
End Sub

[ 続きを読む ]  返信件数:1件  [ 動画を見る] 

[7323]発展編1 フォローメールセミナー 第11回

2016-11-22 18:18:32 受講生さんからの投稿です。

小川先生
お世話になっております。
10月末から勉強させていただいております。
複数シート間で処理をするときのプログラムの書き方がまだしっかりと身についていません。
また変数名を何にするか決めるのに時間がかかり決めた変数名に自信が持てません。
引き続き身につくよう勉強していきます。
読みにくいコードとなり申し訳ありませんがご確認お願いいたします。

Sub denpyoMake()
'mainシートの取引先名称ごとにシートを分ける

    Dim shFm As Worksheet
    Dim shTo As Worksheet
    Dim sortMaeNum As Long
    Dim sortMaeNumMx
    Dim lnfm As Long
    Dim lnfmMx As Long
    Dim lnTo As Long
    Dim dt As Date
    
    Set shFm = Worksheets("main")
    
    'main、main1以外のシートを削除
    deleteSheet
    
    sortMaeNumMx = Range("B" & Rows.Count).End(xlUp).Row
    For sortMaeNum = 2 To sortMaeNumMx
        shFm.Range("A" & sortMaeNum).Value = sortMaeNum - 1
    Next sortMaeNum
    
    'mainシートでソートする
    sortTorihiki
    
    lnfmMx = Range("B" & Rows.Count).End(xlUp).Row
    For lnfm = 2 To lnfmMx
        If shFm.Range("B" & lnfm).Value <> shFm.Range("B" & lnfm - 1).Value Then
            If lnfm <> 2 Then
                '罫線を引く
                keisenDraw (lnTo)
            
                '印刷範囲を設定する
                printSetting (lnTo)
            End If
            
            Worksheets("main1").Copy after:=Worksheets(Worksheets.Count)
            ActiveSheet.Name = shFm.Range("B" & lnfm).Value
            Set shTo = ActiveSheet
            shTo.Range("F2").Value = shTo.Name
            lnTo = 16
        Else
            lnTo = lnTo + 1
        End If
        dt = shFm.Range("C" & lnfm).Value
        shTo.Range("B" & lnTo).Value = Right(Year(dt), 2)
        shTo.Range("C" & lnTo).Value = Month(dt)
        shTo.Range("D" & lnTo).Value = Day(dt)
        shTo.Range("E" & lnTo).Value = shFm.Range("D" & lnfm).Value
        shTo.Range("F" & lnTo).Value = shFm.Range("E" & lnfm).Value
        shTo.Range("H" & lnTo).Value = shFm.Range("F" & lnfm).Value
        If shFm.Range("G" & lnfm).Value > 0 Then
            shTo.Range("I" & lnTo).Value = shFm.Range("G" & lnfm).Value
        Else
            shTo.Range("J" & lnTo).Value = shFm.Range("G" & lnfm).Value
        End If
        shTo.Range("K" & lnTo).Value = shTo.Range("K" & lnTo - 1).Value + shFm.Range("G" & lnfm).Value
            
    Next lnfm
    
    'mainシートを元の順番でソートする
    sortMotojun

    shFm.Activate
    shFm.Range("A1").Select
    
End Sub

Private Sub sortTorihiki()
'取引先名称で並び替える
    
    Columns("A:G").Select
    With Worksheets("main").Sort
        .SortFields.Clear
        .SortFields.Add Key:=Range("B:B"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .SortFields.Add Key:=Range("C:C"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .SortFields.Add Key:=Range("D:D"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .SortFields.Add Key:=Range("E:E"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .SortFields.Add Key:=Range("F:F"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        
        .SetRange Range("A:G")
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    Worksheets("main").Range("A1").Value = "No"
End Sub

Private Sub sortMotojun()
'元の並び順に並び替える
    
    Columns("A:G").Select
    With Worksheets("main").Sort
        .SortFields.Clear
        .SortFields.Add Key:=Range("A:A"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        
        .SetRange Range("A:G")
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    Range("A:A").ClearContents
End Sub

Private Sub deleteSheet()
' main、main1以外のシートを削除する

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

Private Sub keisenDraw(mxGyo As Long)
'追加シートに罫線を引く

    With Range("B16:K" & mxGyo)
        .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 = xlThin
        End With
        With .Borders(xlInsideHorizontal)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlThin
        End With
    End With
End Sub

Private Sub printSetting(maxGyo As Long)
'印刷範囲を変更する。またヘッダ・フッタを入れる。

Range("A1:L" & maxGyo).Select
    ActiveSheet.PageSetup.PrintArea = "A1:L" & maxGyo + 1
    Application.PrintCommunication = False
    With ActiveSheet.PageSetup
        .PrintTitleRows = ""
        .PrintTitleColumns = ""
        .LeftHeader = ""
        .CenterHeader = ""
        .RightHeader = "&D"
        .LeftFooter = ""
        .CenterFooter = ""
        .RightFooter = "&A"
        .LeftMargin = Application.InchesToPoints(0.78740157480315)
        .RightMargin = Application.InchesToPoints(0.78740157480315)
        .TopMargin = Application.InchesToPoints(0.984251968503937)
        .BottomMargin = Application.InchesToPoints(0.984251968503937)
        .HeaderMargin = Application.InchesToPoints(0.511811023622047)
        .FooterMargin = Application.InchesToPoints(0.511811023622047)
        .PrintHeadings = False
        .PrintGridlines = False
        .PrintComments = xlPrintNoComments
        .CenterHorizontally = True
        .CenterVertically = False
        .Orientation = xlLandscape
        .Draft = False
        .PaperSize = xlPaperA4
        .FirstPageNumber = xlAutomatic
        .Order = xlDownThenOver
        .BlackAndWhite = False
        .Zoom = False
        .FitToPagesWide = 10
        .FitToPagesTall = 10
        .PrintErrors = xlPrintErrorsDisplayed
        .OddAndEvenPagesHeaderFooter = False
        .DifferentFirstPageHeaderFooter = False
        .ScaleWithDocHeaderFooter = True
        .AlignMarginsHeaderFooter = False
        .EvenPage.LeftHeader.Text = ""
        .EvenPage.CenterHeader.Text = ""
        .EvenPage.RightHeader.Text = ""
        .EvenPage.LeftFooter.Text = ""
        .EvenPage.CenterFooter.Text = ""
        .EvenPage.RightFooter.Text = ""
        .FirstPage.LeftHeader.Text = ""
        .FirstPage.CenterHeader.Text = ""
        .FirstPage.RightHeader.Text = ""
        .FirstPage.LeftFooter.Text = ""
        .FirstPage.CenterFooter.Text = ""
        .FirstPage.RightFooter.Text = ""
    End With
    Application.PrintCommunication = True
End Sub

[ 続きを読む ]  返信件数:1件  [ 動画を見る] 

[5661]発展編1 フォローメールセミナー 第11回

2016-01-24 15:06:17 受講生さんからの投稿です。

小川先生、いつもお世話になっております。
追加要件の宿題を提出いたします。前回の宿題提出時に頂いたご指導のお陰で、ループの初回の罫線設定回避策もよく理解出来て、スラスラと書けるようになりました。
今回はオートフィルでA列に番号を振る別解としました。オートフィルのハンドル部分をダブルクリックするだけで、表がある部分全てにオートフィルが実行されることは知らなかったので、
また新たな学びが出来ました。(今更というカンジですが…(;・∀・))添削ご指導よろしくお願いいたします。

Sub creatDenpyo()
    deleteDenpyo
    
    Dim wFm As Worksheet
    Set wFm = Worksheets("main")
    Dim wTmp As Worksheet
    Set wTmp = Worksheets("main1")
    Dim wTo As Worksheet
    
    '(1)A列に番号を振る(オートフィルで)
    wFm.Range("A2").FormulaR1C1 = "1"
    wFm.Range("A3").FormulaR1C1 = "2"
    wFm.Range("A2:A3").AutoFill Destination:=wFm.Range("A2:A317")

    '(2)B列でソート
    wFm.Range("A1:G317").Sort Key1:=wFm.Range("B1"), Order1:=xlAscending, Header:=xlYes

    '(3)伝票テンプレートにヘッダー/フッター挿入、印刷範囲設定クリア
    With wTmp.PageSetup
        .CenterHeader = "&A"
        .CenterFooter = "&P / &N ページ"
        .PrintArea = ""
    End With
    
    '(4)伝票作成
    Dim gyo As Long
    Dim gyoMax As Long
    gyoMax = wFm.Range("B" & Rows.Count).End(xlUp).Row
    Dim gyoTo As Long
    gyoTo = 16
    For gyo = 2 To gyoMax
        If wFm.Range("B" & gyo).Value <> wFm.Range("B" & gyo - 1).Value Then
            If gyo > 2 Then
                keisen
            End If
            gyoTo = 16
            wTmp.Copy After:=Sheets(2)
            Set wTo = ActiveSheet
            wTo.Name = wFm.Range("B" & gyo).Value
        End If
        wTo.Range("B" & gyoTo) = Mid(Year(wFm.Range("C" & gyo).Value), 3)
        wTo.Range("C" & gyoTo) = Month(wFm.Range("C" & gyo).Value)
        wTo.Range("D" & gyoTo) = Day(wFm.Range("C" & gyo).Value)
        wTo.Range("E" & gyoTo) = wFm.Range("D" & gyo).Value
        wTo.Range("F" & gyoTo) = wFm.Range("E" & gyo).Value
        wTo.Range("H" & gyoTo) = wFm.Range("F" & gyo).Value
        If wFm.Range("G" & gyo).Value > 0 Then
            wTo.Range("I" & gyoTo) = wFm.Range("G" & gyo).Value
        Else
            wTo.Range("J" & gyoTo) = wFm.Range("G" & gyo).Value
        End If
        If gyoTo > 16 Then
            wTo.Range("K" & gyoTo) = wTo.Range("I" & gyoTo).Value + wTo.Range("J" & gyoTo).Value + wTo.Range("K" & gyoTo - 1).Value
        Else
            wTo.Range("K" & gyoTo) = wTo.Range("I" & gyoTo).Value + wTo.Range("J" & gyoTo).Value
        End If
        gyoTo = gyoTo + 1
    Next
    keisen

    '(5)A列でソート
    wFm.Range("A1:G317").Sort Key1:=wFm.Range("A1"), Order1:=xlAscending, Header:=xlYes

    '(6)A列の値消去
    wFm.Range("A1:A317").ClearContents
End Sub

Sub deleteDenpyo()
    Dim ws As Worksheet
    Application.DisplayAlerts = False
    For Each ws In Worksheets
        If ws.Name <> "main1" And ws.Name <> "main" Then
            ws.Delete
        End If
    Next
    Application.DisplayAlerts = True
End Sub

Sub keisen()
    Dim gyoMax
    gyoMax = Range("B" & Rows.Count).End(xlUp).Row
    
    With Range("B16", "K" & gyoMax)
        With .Borders(xlEdgeLeft)
            .LineStyle = xlContinuous
            .Weight = xlThin
        End With
        With .Borders(xlEdgeTop)
            .LineStyle = xlContinuous
            .Weight = xlThin
        End With
        With .Borders(xlEdgeBottom)
            .LineStyle = xlContinuous
            .Weight = xlThin
        End With
        With .Borders(xlEdgeRight)
            .LineStyle = xlContinuous
            .Weight = xlThin
        End With
        With .Borders(xlInsideVertical)
            .LineStyle = xlContinuous
            .Weight = xlHairline
        End With
        With .Borders(xlInsideHorizontal)
            .LineStyle = xlContinuous
            .Weight = xlHairline
        End With
    End With
End Sub

[ 続きを読む ]  返信件数:1件  [ 動画を見る] 

[2781]発展編1 フォローメールセミナー 第11回

2014-10-22 23:25:52 受講生さんからの投稿です。

分からない部分はマクロ記録で調べながら、宿題を完成させ提出しました。
インデントを設定してここに貼り付けても、「送信」した時点でインデントが消えてしまいます。

[ 続きを読む ]  返信件数:1件  [ 動画を見る] 


各講座ごとのメッセージを見る場合はこちら

 

まずはここから!スマホでも学べる無料動画講座

今なら先着30名限定で無料!定価4,800円の、初心者のためのエクセルマクロ動画講座。
  1. Excel 97~Excel 2016まですべて対応。動画本数20本、総再生時間2時間44分53秒
  2. PC, Mac, iPhone, iPad, Androidのお好みの環境で、いつでも好きなときに学べます。
2004年から10年間述べ3,000名以上に実施した研修の経験と実績を集約した講座です。
いますぐ無料で試してください。

トップへ