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
2019/02/13 14:06
小川 慶一さんのコメント
(コメントID: 6029)
A.Sさん:
添削を返送します。 びっくりするくらい上達されていますね!
ひきつづき、マクロの学習をお楽しみください☆
Option Explicit
'ひと目見て、できそう!と思わせられるサマリーですね (^^
'各プロシージャ先頭に示された機能のサマリも分かりやすいです。
Sub CreateDenpyo()
DeleteSheets
Template_Setup '←これは、プログラムで行わないで、プログラム実行前に手作業でやっておいてもOK。というか、一度すれば再度実行する必要のない作業なので、実は、そうするのが正解です。
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."
'autofillを使った方法も研究してみてください
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の中身は一段下げる。 _ を使って途中改行している場合も、その行の終わりまでは、一段下げる
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の中身は一段下げる。 _ を使って途中改行している場合も、その行の終わりまでは、一段下げる
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 'Sub CreateDenpyo() の一行目で実行済なので不要ですね
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
'↓format関数の使い方、秀逸です (^^
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)
'↓以下2行はインデント不正。withの中は一段右へ。
.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
Public Sub CreateDenpyo()
DeleteSheets
Numbering
Narabekae_Torihikisaki
Denpyosheet_Set
Narabekae_No
NumberingDelete
End Sub
'「main1」シートのページ設定をするマクロ(実行は1回のみ)
Private Sub Template_Setup()
With Sheets("main1").PageSetup
.PrintArea = "" '印刷範囲の解除
.CenterHeader = "&A" 'ヘッダーに「シート名」を挿入
.CenterFooter = "&P" 'フッターに「ページ番号」を挿入
End With
Range("A1").Select
End Sub
'「main」シートのA列に番号を振るマクロ(AutoFill使用)
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
ws.Range("A2").Value = "2"
ws.Range("A3").Value = "3"
ws.Range("A2:A3").AutoFill Destination:=Range("A2:A" & lnMx)
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
'取引先名称シートに罫線を作成するマクロ
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
'「main」シートのB列を昇順に並び替えるマクロ
Private Sub Narabekae_Torihikisaki()
Dim lnMx As Long
Dim ws As Worksheet
Set ws = Worksheets("main")
lnMx = ws.Range("A" & Rows.Count).End(xlUp).Row
With ws.Sort 'インデント修正
.SortFields.Clear
.SortFields.Add Key:=Range("B2:B" & lnMx), _
SortOn:=xlSortOnValues, _
Order:=xlAscending, _
DataOption:=xlSortNormal
.SetRange Range("A1:G" & lnMx)
.Header = xlYes
.Apply
End With
End Sub
'「main」シートのA列を昇順に並び替えるマクロ
Private Sub Narabekae_No()
Dim lnMx As Long
Dim ws As Worksheet
Set ws = Worksheets("main")
lnMx = ws.Range("A" & Rows.Count).End(xlUp).Row
With ws.Sort 'インデント修正
.SortFields.Clear
.SortFields.Add Key:=Range("A2:A" & lnMx), _
SortOn:=xlSortOnValues, _
Order:=xlAscending, _
DataOption:=xlSortNormal
.SetRange Range("A1:G" & lnMx)
.Header = xlYes
.Apply
End With
End Sub
A.Sさんの投稿
(投稿ID: 4385) 添付ファイルのダウンロード権限がありません
いつもお世話になっております。
第9回に引き続き、第11回の宿題を提出させていただきます。
お忙しいところ大変恐れ入りますが、添削の程、どうぞよろしくお願い致します。
小川 慶一さんのコメント
(コメントID: 6029)
添削を返送します。
びっくりするくらい上達されていますね!
ひきつづき、マクロの学習をお楽しみください☆
A.Sさんのコメント
(コメントID: 6035) 添付ファイルのダウンロード権限がありません
お忙しい中、添削ありがとうございます。
コメントをいただいた箇所を修正しました。
再度、恐れ入りますが、ご確認の程、よろしくお願い致します。
小川 慶一さんのコメント
(コメントID: 6040)
拝見しました。
もう、ご自身でもおっしゃっていましたが、十分にスキルが身についたのではないか?と思います。
並べ替えのマクロで、最終行が何行目でも動くようになおしましょう。
そこだけですね。
ひきつづき、マクロの習得、お楽しみください☆
A.Sさんのコメント
(コメントID: 6041)
コメントありがとうございます。
並べ替えのマクロを修正しました。
引き続き、メールセミナーの受講を行わせていただきます。
今後とも、ご指導の程、よろしくお願い致します。
小川 慶一さんのコメント
(コメントID: 6044)
v(^^*