Option Explicit
Dim G_retu As String
Public Sub main()
Application.DisplayAlerts = False
Application.ScreenUpdating = False
sheetDelete
writeNo
G_retu = "B"
sorting
sheetcreat
G_retu = "A"
sorting
Aclear
Worksheets("main").Select
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Public Sub sheetDelete()
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 writeNo()
Dim ws As Worksheet
Dim lnFmMx As Long
Dim ln As Long
Set ws = Worksheets("main")
lnFmMx = ws.Range("B" & ws.Rows.Count).End(xlUp).Row
For ln = 2 To lnFmMx
ws.Range("A" & ln).Value = ln - 1
Next
End Sub
Private Sub sorting()
Dim lnMx As Long
lnMx = Range("B" & Rows.Count).End(xlUp).Row
Range(G_retu & "1").Select
ActiveWorkbook.Worksheets("main").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("main").Sort.SortFields.Add2 Key:=Range(G_retu & "1"), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("main").Sort
.SetRange Range("A2:G" & lnMx)
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End Sub
Private Sub sheetcreat()
Dim shFm As Worksheet
Dim shTo As Worksheet
Dim lnFm As Long
Dim lnFmMx As Long
Dim lnTo As Long
Dim strName As String
Dim dt As Date
Set shFm = Worksheets("main")
lnFmMx = shFm.Range("B" & shFm.Rows.Count).End(xlUp).Row
For lnFm = 2 To lnFmMx
If strName <> shFm.Range("B" & lnFm).Value Then
If lnFm > 2 Then
keisen
End If
strName = shFm.Range("B" & lnFm).Value
Debug.Print strName
Sheets("main1").Copy After:=Sheets(2)
Set shTo = ActiveSheet
shTo.Name = strName
lnTo = 16
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
Select Case shFm.Range("G" & lnFm).Value
Case Is > 0
shTo.Range("I" & lnTo).Value = shFm.Range("G" & lnFm).Value
Case Else
shTo.Range("J" & lnTo).Value = shFm.Range("G" & lnFm).Value
End Select
If lnTo = 16 Then
shTo.Range("K" & lnTo).Value = shFm.Range("G" & lnFm).Value
Else
shTo.Range("K" & lnTo).Value = shFm.Range("G" & lnFm).Value + shTo.Range("K" & lnTo).Offset(-1, 0).Value
End If
lnTo = lnTo + 1
Next
keisen
End Sub
Private Sub keisen()
Dim lnMx As Long
lnMx = Range("B" & Rows.Count).End(xlUp).Row
Range("B16:K" & lnMx).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
Private Sub Aclear()
Dim lnMx
lnMx = Worksheets("main").Range("A" & Worksheets("main").Rows.Count).End(xlUp).Row
Debug.Print lnMx
Worksheets("main").Range("A2:A" & lnMx).Clear
End Sub
2020/05/23 23:54
小川慶一さんのコメント
(コメントID: 6611)
受講生 さん:
こんばんは。
添削を返送します。 全体に、とてもしっかり書けていると感じます。 With ... End With の中身の整理は今回お送りした添削内容を元に練習してみてください。
次回添削課題を拝見するのを楽しみにしています。
Option Explicit
Dim G_retu As String
Public Sub main()
Application.DisplayAlerts = False
Application.ScreenUpdating = False
sheetDelete
writeNo
G_retu = "B"
sorting
sheetcreat
G_retu = "A"
'シート「main」の表は、実行前の順序に戻りますでしょうか。僕の環境では戻りませんでした。この書き方だとたぶん戻らないはずです。
' Worksheets("main").Select '←これがあれば確実に元に戻る。でなければ?(*1)を参照してください。
sorting
Aclear
Worksheets("main").Select
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Public Sub sheetDelete()
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 writeNo()
Dim ws As Worksheet
Dim lnFmMx As Long
Dim ln As Long
'autofillを使う方法も研究してみてください。
Set ws = Worksheets("main")
lnFmMx = ws.Range("B" & ws.Rows.Count).End(xlUp).Row
For ln = 2 To lnFmMx
ws.Range("A" & ln).Value = ln - 1
Next
End Sub
Private Sub sorting_sample()
'(*1) アクティブでないシートのセルを指定するのは結構面倒です。
'並べ替えは、慣れないうちは、並べ替え対象のシートをアクティブにしてからのほうがそういう意味でよいです。
'いただいたマクロで、シートの指定がない箇所を明示してみました
Dim lnMx As Long
lnMx = Range("B" & Rows.Count).End(xlUp).Row 'セルの前に、worksheetの指定が抜けている
Range(G_retu & "1").Select 'セルの前に、worksheetの指定が抜けている
ActiveWorkbook.Worksheets("main").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("main").Sort.SortFields.Add2 Key:=Range(G_retu & "1"), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal 'Key:=Range(G_retu & "1")で、セルの前に、worksheetの指定が抜けている(抜けていても実務上はいちおうOKなようだが)
With ActiveWorkbook.Worksheets("main").Sort
.SetRange Range("A2:G" & lnMx) 'セルの前に、worksheetの指定が抜けている(抜けていても実務上はいちおうOKなようだが)
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End Sub
Private Sub sorting()
'このプロシージャの中身に最適化については、 sorting_sample に記載したこと、keisen_sample に記載したことを研究の上、再トライしてみてください。
'次回課題提出いただいたときに整理してお伝えしたいと思います。
Dim lnMx As Long
lnMx = Worksheets("main").Range("B" & Rows.Count).End(xlUp).Row
' Worksheets("main").Range(G_retu & "1").Select '不要
ActiveWorkbook.Worksheets("main").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("main").Sort.SortFields.Add2 Key:=Worksheets("main").Range(G_retu & "1"), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("main").Sort
.SetRange Worksheets("main").Range("A2:G" & lnMx)
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End Sub
Private Sub sheetcreat()
Dim shFm As Worksheet
Dim shTo As Worksheet
Dim lnFm As Long
Dim lnFmMx As Long
Dim lnTo As Long
Dim strName As String
Dim dt As Date
Set shFm = Worksheets("main")
lnFmMx = shFm.Range("B" & shFm.Rows.Count).End(xlUp).Row
For lnFm = 2 To lnFmMx
If strName <> shFm.Range("B" & lnFm).Value Then
If lnFm > 2 Then
keisen
End If
strName = shFm.Range("B" & lnFm).Value
Debug.Print strName
Sheets("main1").Copy After:=Sheets(2)
Set shTo = ActiveSheet
shTo.Name = strName
lnTo = 16
End If
dt = shFm.Range("C" & lnFm).Value
'以下の3つ、format関数を適用することも試してみてください
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
Select Case shFm.Range("G" & lnFm).Value
Case Is > 0
shTo.Range("I" & lnTo).Value = shFm.Range("G" & lnFm).Value
Case Else
shTo.Range("J" & lnTo).Value = shFm.Range("G" & lnFm).Value
End Select
If lnTo = 16 Then
shTo.Range("K" & lnTo).Value = shFm.Range("G" & lnFm).Value
Else
shTo.Range("K" & lnTo).Value = shFm.Range("G" & lnFm).Value + shTo.Range("K" & lnTo).Offset(-1, 0).Value
End If
lnTo = lnTo + 1
Next
keisen
End Sub
Private Sub keisen_sample()
'以下の要領で
Dim lnMx As Long
lnMx = Range("B" & Rows.Count).End(xlUp).Row
With Range("B16:K" & lnMx)
.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
End With
End Sub
Private Sub keisen()
Dim lnMx As Long
lnMx = Range("B" & Rows.Count).End(xlUp).Row
Range("B16:K" & lnMx).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
Private Sub Aclear()
Dim lnMx
lnMx = Worksheets("main").Range("A" & Worksheets("main").Rows.Count).End(xlUp).Row
Debug.Print lnMx
Worksheets("main").Range("A2:A" & lnMx).Clear
End Sub
Dim G_retu As String
Public Sub main()
Application.DisplayAlerts = False
Application.ScreenUpdating = False
sheetDelete
writeNo
G_retu = "B"
sorting
sheetcreat
G_retu = "A"
sorting
Aclear
Worksheets("main").Select
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Public Sub sheetDelete()
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 writeNo()
Dim lnMx As Long
lnMx = Worksheets("main").Range("B" & Worksheets("main").Rows.Count).End(xlUp).Row
With Worksheets("main")
.Range("A2").Value = 1
.Range("A3").Value = 2
.Range("A2:A3").AutoFill Destination:=Range("A2:A" & lnMx), Type:=xlFillDefault
End With
End Sub
Private Sub sorting()
Dim lnMx As Long
lnMx = Worksheets("main").Range("B" & Rows.Count).End(xlUp).Row
With Worksheets("main")
.Select
.Range(G_retu & "1").Select
.Sort.SortFields.Clear
.Sort.SortFields.Add2 Key:=Worksheets("main").Range(G_retu & "1"), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With .Sort
.SetRange Worksheets("main").Range("A2:G" & lnMx)
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End With
End Sub
Private Sub sheetcreat()
Dim shFm As Worksheet
Dim shTo As Worksheet
Dim lnFm As Long
Dim lnFmMx As Long
Dim lnTo As Long
Dim strName As String
Dim dt As Date
Set shFm = Worksheets("main")
lnFmMx = shFm.Range("B" & shFm.Rows.Count).End(xlUp).Row
For lnFm = 2 To lnFmMx
If strName <> shFm.Range("B" & lnFm).Value Then
If lnFm > 2 Then
keisen
End If
strName = shFm.Range("B" & lnFm).Value
Debug.Print strName
Sheets("main1").Copy After:=Sheets(2)
Set shTo = ActiveSheet
shTo.Name = strName
lnTo = 16
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
Select Case shFm.Range("G" & lnFm).Value
Case Is > 0
shTo.Range("I" & lnTo).Value = shFm.Range("G" & lnFm).Value
Case Else
shTo.Range("J" & lnTo).Value = shFm.Range("G" & lnFm).Value
End Select
If lnTo = 16 Then
shTo.Range("K" & lnTo).Value = shFm.Range("G" & lnFm).Value
Else
shTo.Range("K" & lnTo).Value = shFm.Range("G" & lnFm).Value + shTo.Range("K" & lnTo).Offset(-1, 0).Value
End If
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)
.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
End With
End Sub
Private Sub Aclear()
Dim lnMx
lnMx = Worksheets("main").Range("A" & Worksheets("main").Rows.Count).End(xlUp).Row
Debug.Print lnMx
Worksheets("main").Range("A2:A" & lnMx).Clear
End Sub
基本の考え方は、「オブジェクトを指定している部分が重複しているなら with でまとめ得る」です。この表現で必要十分です。 「プロパティ、メソッドも with でまとめ得る」というのはちょっと違います。 たとえば、上位のオブジェクトから見たらそのオブジェクトのプロパティと見えるものがあったとしても、その「上位のオブジェクトから見たらプロパティ」なもの自身が「オブジェクト」であれば with で指定するオブジェクト足り得ます。メソッドも、その戻り値(*発展編2で出てくる用語。ざっくり言うと、その言葉か指すもの)がオブジェクトならば with でまとめ得ます。
with workbooks("book1.xlsm")
' ...
' ...
' ...
end with
with workbooks("book1.xlsm").worksheets("sheet1")
' ...
' ...
' ...
end with
with workbooks("book1.xlsm").worksheets("sheet1").range("a1")
' ...
' ...
' ...
end with
もう少し具体的な例を示します。 たとえば、以下の with_sample_before のようなコードがあったとして with_sample_after1, with_sample_after2, with_sample_after3 のどの手直しの仕方もありです。 .Range("a1") だけでなく、 .Font, .CurrentRegion のどれも、戻り値はオブジェクトです。ですので以下のどれもOKです。(前者は戻り値として Font オブジェクトを返し、後者は戻り値として Range オブジェクトを返す)
Sub Initialize()
'事前準備
Worksheets("sheet1").Range("a1").CurrentRegion.Clear
Worksheets("sheet1").Range("e1").Clear
Worksheets("sheet1").Range("a1").Value = "no"
Worksheets("sheet1").Range("b1").Value = "会社名"
Worksheets("sheet1").Range("c1").Value = "担当者名"
Dim c As Long
For c = 2 To 11
Worksheets("sheet1").Range("a" & c).Value = c - 1
Worksheets("sheet1").Range("b" & c).Value = "会社" & c - 1
Worksheets("sheet1").Range("c" & c).Value = "担当者名" & c - 1
Next
End Sub
Sub with_sample_before()
Initialize
'以下を with を使ってリライトしてみましょう
Worksheets("sheet1").Range("a1").Value = "番号"
Worksheets("sheet1").Range("a1").Font.Color = vbBlue
Worksheets("sheet1").Range("a1").Font.Size = 12
Worksheets("sheet1").Range("a1").CurrentRegion.Sort Key1:=Worksheets("sheet1").Range("A1"), Order1:=xlDescending, Header:=xlYes
Worksheets("sheet1").Range("e1").Value = Worksheets("sheet1").Range("a1").CurrentRegion.Count
End Sub
Sub with_sample_after1()
Initialize
'リライト例1
With Worksheets("sheet1")
.Range("a1").Value = "番号"
.Range("a1").Font.Color = vbBlue
.Range("a1").Font.Size = 12
.Range("a1").CurrentRegion.Sort Key1:=.Range("A1"), Order1:=xlDescending, Header:=xlYes
.Range("e1").Value = .Range("a1").CurrentRegion.Count
End With
End Sub
Sub with_sample_after2()
Initialize
'リライト例2
With Worksheets("sheet1").Range("a1")
.Value = "番号"
.Font.Color = vbBlue
.Font.Size = 12
.CurrentRegion.Sort Key1:=Worksheets("sheet1").Range("A1"), Order1:=xlDescending, Header:=xlYes
Worksheets("sheet1").Range("e1").Value = .CurrentRegion.Count
End With
End Sub
Sub with_sample_after3()
Initialize
'リライト例3
With Worksheets("sheet1").Range("a1")
.Value = "番号"
With .Font
.Color = vbBlue
.Size = 12
End With
With .CurrentRegion
.Sort Key1:=Worksheets("sheet1").Range("A1"), Order1:=xlDescending, Header:=xlYes
Worksheets("sheet1").Range("e1").Value = .Count
End With
End With
End Sub
'コメント付与しました
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
以下は添削です。
Dim G_retu As String
Public Sub main()
Application.DisplayAlerts = False
Application.ScreenUpdating = False
sheetDelete
writeNo
G_retu = "B"
sorting
sheetcreat
G_retu = "A"
sorting
Aclear
Worksheets("main").Select
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Public Sub sheetDelete()
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 writeNo()
Dim lnMx As Long
' lnMx = Worksheets("main").Range("B" & Worksheets("main").Rows.Count).End(xlUp).Row
With Worksheets("main")
lnMx = .Range("B" & .Rows.Count).End(xlUp).Row '右辺にくるオブジェクトもwithで表現できる
.Range("A2").Value = 1
.Range("A3").Value = 2
' .Range("A2:A3").AutoFill Destination:=Range("A2:A" & lnMx), Type:=xlFillDefault
.Range("A2:A3").AutoFill Destination:=.Range("A2:A" & lnMx), Type:=xlFillDefault 'Destinationのセル指定で先頭の「 . 」が抜けています
End With
End Sub
Private Sub sorting_tensau0() '添削前の状態
Dim lnMx As Long
lnMx = Worksheets("main").Range("B" & Rows.Count).End(xlUp).Row
With Worksheets("main")
.Select
.Range(G_retu & "1").Select
.Sort.SortFields.Clear
.Sort.SortFields.Add2 Key:=Worksheets("main").Range(G_retu & "1"), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With .Sort
.SetRange Worksheets("main").Range("A2:G" & lnMx)
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End With
End Sub
Private Sub sorting_tensaku1()
Dim lnMx As Long
lnMx = Worksheets("main").Range("B" & Rows.Count).End(xlUp).Row
With Worksheets("main")
.Select
.Range(G_retu & "1").Select
.Sort.SortFields.Clear
.Sort.SortFields.Add2 _
Key:=Worksheets("main").Range(G_retu & "1"), _
SortOn:=xlSortOnValues, _
Order:=xlAscending, _
DataOption:=xlSortNormal '事前準備。可読性向上のために改行を増やした。
With .Sort
.SetRange Worksheets("main").Range("A2:G" & lnMx)
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End With
End Sub
Private Sub sorting_tensaku2()
Dim lnMx As Long
With Worksheets("main")
lnMx = .Range("B" & Rows.Count).End(xlUp).Row
' .Select
' .Range(G_retu & "1").Select
.Sort.SortFields.Clear
.Sort.SortFields.Add2 _
Key:=.Range(G_retu & "1"), _
SortOn:=xlSortOnValues, _
Order:=xlAscending, _
DataOption:=xlSortNormal 'key1:= で Worksheets("main"). を . に変更
With .Sort
.SetRange Worksheets("main").Range("A2:G" & lnMx)
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End With
End Sub
Private Sub sorting_tensaku3()
Dim lnMx As Long
With Worksheets("main")
lnMx = .Range("B" & Rows.Count).End(xlUp).Row
With .Sort '.sort でまとめてみる
.SortFields.Clear
.SortFields.Add2 _
Key:=Worksheets("main").Range(G_retu & "1"), _
SortOn:=xlSortOnValues, _
Order:=xlAscending, _
DataOption:=xlSortNormal 'key1:= で Worksheets("main"). は復活させざるを得ない。(.Sort内だから)
.SetRange Worksheets("main").Range("A2:G" & lnMx)
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End With
End Sub
Private Sub sorting_tensaku4()
Dim lnMx As Long
With Worksheets("main")
lnMx = .Range("B" & Rows.Count).End(xlUp).Row
With .Sort
With .SortFields '.sortfields でまとめてみる
.Clear
.Add2 _
Key:=Worksheets("main").Range(G_retu & "1"), _
SortOn:=xlSortOnValues, _
Order:=xlAscending, _
DataOption:=xlSortNormal
End With
.SetRange Worksheets("main").Range("A2:G" & lnMx)
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End With
End Sub
Private Sub sorting()
Dim lnMx As Long
With Worksheets("main")
lnMx = .Range("B" & Rows.Count).End(xlUp).Row
With .Sort
With .SortFields '.sortfields でまとめてみる
.Clear
.Add2 _
Key:=Worksheets("main").Range(G_retu & "1"), _
SortOn:=xlSortOnValues, _
Order:=xlAscending, _
DataOption:=xlSortNormal
End With
.SetRange Worksheets("main").Range("A2:G" & lnMx)
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End With
End Sub
Private Sub sheetcreat()
Dim shFm As Worksheet
Dim shTo As Worksheet
Dim lnFm As Long
Dim lnFmMx As Long
Dim lnTo As Long
Dim strName As String
Dim dt As Date
Set shFm = Worksheets("main")
lnFmMx = shFm.Range("B" & shFm.Rows.Count).End(xlUp).Row
For lnFm = 2 To lnFmMx
If strName <> shFm.Range("B" & lnFm).Value Then
If lnFm > 2 Then
keisen
End If
strName = shFm.Range("B" & lnFm).Value
Debug.Print strName
Sheets("main1").Copy After:=Sheets(2)
Set shTo = ActiveSheet
shTo.Name = strName
lnTo = 16
End If
dt = shFm.Range("C" & lnFm).Value
shTo.Range("B" & lnTo).Value = Format(dt, "yy") 'Right(Year(dt), 2)
shTo.Range("C" & lnTo).Value = Format(dt, "mm") 'Month(dt)
shTo.Range("D" & lnTo).Value = Format(dt, "dd") '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
Select Case shFm.Range("G" & lnFm).Value
Case Is > 0
shTo.Range("I" & lnTo).Value = shFm.Range("G" & lnFm).Value
Case Else
shTo.Range("J" & lnTo).Value = shFm.Range("G" & lnFm).Value
End Select
If lnTo = 16 Then
shTo.Range("K" & lnTo).Value = shFm.Range("G" & lnFm).Value
Else
shTo.Range("K" & lnTo).Value = shFm.Range("G" & lnFm).Value + shTo.Range("K" & lnTo).Offset(-1, 0).Value
End If
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)
.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
End With
End Sub
Private Sub Aclear()
Dim lnMx
lnMx = Worksheets("main").Range("A" & Worksheets("main").Rows.Count).End(xlUp).Row
Debug.Print lnMx
Worksheets("main").Range("A2:A" & lnMx).Clear
End Sub
受講生さんの投稿
(投稿ID: 4737)
伝票作成マクロを一通り受講したのち、一から記憶を頼りに作成してみました。
挙動については問題なかったので、あとは不必要な部分やセオリーに反している部分があればご指摘いただけると幸いです。
なお一点、並び替えマクロ(プロシージャ名:sorting)にて自動記述後取捨選択箇所の判断がつかずそのまま活用している為(セミナー内に記載されていた例と同じコードが自動で書かれなかったので・・・)、不要な部分とその判断方法をご教示頂けたら嬉しいです。
小川慶一さんのコメント
(コメントID: 6611)
こんばんは。
添削を返送します。
全体に、とてもしっかり書けていると感じます。
With ... End With の中身の整理は今回お送りした添削内容を元に練習してみてください。
次回添削課題を拝見するのを楽しみにしています。
受講生さんのコメント
(コメントID: 6615)
早速添削ありがとうございます。
頂いたコメントに沿って添削してみたので再投稿させていただきます。
なお、そのうえでの確認(質問)事項は以下点です。
①worksheet("main")A列に番号を割り振るマクロにてオートフィルを活用しコードを記述してみました。
使い方としてはこのような感じであっておりますでしょうか?
②withの中身について並び替えマクロ(sorting)も自分なりに改編してみました。一応動きました。
select/selectionについては基本まとめる、というお話がありましたが、その上で同じオブジェクトやプロパティ、メソッドを連続して指定しているコードがあればwitでまとめる、みたいな考え方で正しいでしょうか?
③ご指摘いただいている中で「'以下の3つ、format関数を適用することも試してみてください」の部分だけ、アドバイス頂いた内容が理解できませんでした・・・浅識で申し訳ございません・・・。
④サブプロシージャ:keisenの中身を頂いたアドバイス通りに添削してみました(というかほぼ頂いたもののコピペですが・・・)
すると各シートの罫線が記載されなくなってしまったのですが、何か必要部分を消してしまっているのでしょうか・・・?
小川慶一さんのコメント
(コメントID: 6617)
おはようございます。
添削を返送します。
> ①worksheet("main")A列に番号を割り振るマクロにてオートフィルを活用しコードを記述してみました。
> 使い方としてはこのような感じであっておりますでしょうか?
良いかと思います。
他の方のコードも参考にしてみてください。このウェブページ内を autofill というキーワードで検索するといろいろ出てきます。
> ②withの中身について並び替えマクロ(sorting)も自分なりに改編してみました。一応動きました。
> select/selectionについては基本まとめる、というお話がありましたが、その上で同じオブジェクトやプロパティ、メソッドを連続して指定しているコードがあればwitでまとめる、みたいな考え方で正しいでしょうか?
基本の考え方は、「オブジェクトを指定している部分が重複しているなら with でまとめ得る」です。この表現で必要十分です。
「プロパティ、メソッドも with でまとめ得る」というのはちょっと違います。
たとえば、上位のオブジェクトから見たらそのオブジェクトのプロパティと見えるものがあったとしても、その「上位のオブジェクトから見たらプロパティ」なもの自身が「オブジェクト」であれば with で指定するオブジェクト足り得ます。メソッドも、その戻り値(*発展編2で出てくる用語。ざっくり言うと、その言葉か指すもの)がオブジェクトならば with でまとめ得ます。
たとえば、 workbooks("book1.xlsm").worksheets("sheet1").range("a1").value = 3 というコードがあったとして、
workbooks("book1.xlsm") はオブジェクトです。
worksheets("sheet1") は workbooks("book1.xlsm") から見ればプロパティですが、 worksheets("sheet1") 自身はオブジェクトです。
range("a1") は worksheets("sheet1") から見ればプロパティですが、 range("a1") 自身はオブジェクトです。
よって、以下のどの書き方も可能です。
もう少し具体的な例を示します。
たとえば、以下の with_sample_before のようなコードがあったとして with_sample_after1, with_sample_after2, with_sample_after3 のどの手直しの仕方もありです。
.Range("a1") だけでなく、 .Font, .CurrentRegion のどれも、戻り値はオブジェクトです。ですので以下のどれもOKです。(前者は戻り値として Font オブジェクトを返し、後者は戻り値として Range オブジェクトを返す)
なお、念のために補足すると、「(withを使わない書き方も含めて)以下のうちどれかだけが正解/最適化された状態であり、どれかだけができるようになっていれば良い」というものではありません。
どのオブジェクトについてまとめた表現にするか?どこまでやるべきか?というのはケースバイケースです。
「ケースバイケース」なので、どの書き方も自在にできるようになるまで練習する必要があります。
「自分の技術的な限界のためにこのやり方しか選択できない」となるとコーディングに不自由が生じてしまうからです。
添削内でも、修正過程を含めて示しました。
実際に同様の過程を経てやってみてください。
> ③ご指摘いただいている中で「'以下の3つ、format関数を適用することも試してみてください」の部分だけ、アドバイス頂いた内容が理解できませんでした・・・浅識で申し訳ございません・・・。
添削を参照してください。
また、添削を参考にして Format 関数についてご自身で研究してみてください。ネットを検索すると、サンプルがいろいろ転がっています。
> ④サブプロシージャ:keisenの中身を頂いたアドバイス通りに添削してみました(というかほぼ頂いたもののコピペですが・・・)
> すると各シートの罫線が記載されなくなってしまったのですが、何か必要部分を消してしまっているのでしょうか・・・?
以下のとおりなので、左辺と上辺にはきちんと罫線が引かれています。(上辺はもともとある15行目の下辺にある線とかぶるので見た目上変化はないですが)
ということで、あとは、底辺、右辺、内部の縦線、内部の横線ですね。
当初いただいたものでは、まだ以下がありますね。
コメントにて「以下の要領で」と書いたのは、以下についても同様にリライトしてくださいという趣旨でした。やってみてください。
以下は添削です。