Option Explicit
'ここまで作り込んだのであればソース内のよけいな空白行は極力潰して、可読性をより高めたいすね。 ogawa
Dim sColSort As String '小川追加。 ogawa
Sub numbering()
'putting ID numbers
Dim gyo As Long
Dim bot As Long 'bottomline
Dim wm As Worksheet
Set wm = Worksheets("main")
bot = wm.Range("B" & Excel.Rows.Count).End(xlUp).Row
For gyo = 2 To bot
wm.Range("A" & gyo) = gyo - 1
Next gyo
wm.Range("a1").Value = "No"
End Sub
Sub sortB()
' sort by column B
Dim bot As Long 'bottomline
Dim wm As Worksheet
Set wm = Worksheets("main")
wm.Activate
bot = wm.Range("B" & Excel.Rows.Count).End(xlUp).Row
With ActiveWorkbook.Worksheets("main").Sort
.SortFields.Clear
' .SortFields.Add Key:=Range("B2:B" & bot), _
' Order:=xlAscending
.SortFields.Add Key:=Range("B2:B" & bot), Order:=xlAscending '←このくらいなら1行でいいかも。 ogawa
.SetRange Range("A1:G" & bot)
.Header = xlYes
.Apply
End With
End Sub
Sub sortA()
'sort by column A that is ID number
Dim bot As Long 'bottomline
Dim wm As Worksheet
Set wm = Worksheets("main")
wm.Activate
bot = wm.Range("B" & Excel.Rows.Count).End(xlUp).Row
With ActiveWorkbook.Worksheets("main").Sort
.SortFields.Clear
' .SortFields.Add Key:=Range("A2:A" & bot), _
' Order:=xlAscending
.SortFields.Add Key:=Range("A2:A" & bot), Order:=xlAscending '←このくらいなら1行でいいかも。 ogawa
.SetRange Range("A1:G" & bot)
.Header = xlYes
.Apply
End With
End Sub
Sub CreateDenpyo()
'create a denpyo sheet for each company listed in the "main" sheet
Dim bot As Long 'bottomline
Dim wm As Worksheet
Dim w As Worksheet
Dim gyo As Long
Dim wm1 As Worksheet
Dim ln As Long 'adding aline in a distination sheet
Dim stv As Long ' sotre the cumulative value of the invoice amounts
Dim wd As Worksheet ' destinatnion sheet
Set wm = Worksheets("main")
Set wm1 = Worksheets("main1")
' DeleteSheets '小川案でいくならこのタイミングでの呼び出しは不要。 ogawa
bot = wm.Range("B" & Excel.Rows.Count).End(xlUp).Row
For gyo = 2 To bot
If wm.Range("B" & gyo).Value <> wm.Range("B" & gyo - 1).Value Then
wm1.Copy after:=Sheets(2) 'make a copy
ActiveSheet.Name = wm.Range("B" & gyo).Value
Set wd = Worksheets(wm.Range("B" & gyo).Value) 'Added newly to store the destination sheet into wd
ln = 16
stv = 0
End If
stv = stv + wm.Range("G" & gyo)
wd.Range("E" & ln) = wm.Range("B" & gyo) 'move each line from the main sheet to a corresponding destination sheet
wd.Range("f" & ln) = wm.Range("e" & gyo) 'wd was put in front to clarify the destinatnion sheet which the code works on
wd.Range("b" & ln) = Format(wm.Range("c" & gyo), "yy") 'Format function was tried out in these three lines per Mr Ogawa's suggestion
wd.Range("c" & ln) = Format(wm.Range("c" & gyo), "mm")
wd.Range("d" & ln) = Format(wm.Range("c" & gyo), "dd")
wd.Range("k" & ln) = stv
If wm.Range("G" & gyo) < 0 Then 'distingush negatives from positives
wd.Range("i" & ln) = wm.Range("G" & gyo)
Else
wd.Range("j" & ln) = wm.Range("G" & gyo)
End If
ln = ln + 1
'keisen 'NOT A GOOD OPTION - adding "Keisen" immediately after the completion of a destinatnion sheet
Next gyo
End Sub
Sub DeleteSheets()
Dim w As Worksheet
Application.DisplayAlerts = False
For Each w In Worksheets
Select Case w.Name 'used select case clause instead of If clause
Case "main", "main1", "mainButton"
Case Else
w.Delete
End Select
Next
Application.DisplayAlerts = True
End Sub
Sub keisen()
Dim w As Worksheet
' Application.ScreenUpdating = False '←末尾に =true とセットで入れたいところ。
'画面のチラつき防止だけでなく、高速化にも寄与します。 ogawa
For Each w In Worksheets
If Left(w.Name, 4) <> "main" Then
'adding border lines
Dim bot As Long
' w.Activate WAS REMOVED PURPOSEFULLY TO CAUSE AN ERROR
bot = w.Range("B" & Excel.Rows.Count).End(xlUp).Row
w.Activate 'need to acitvate the worksheet including the range you want to select. ogawa
' w.Range("B16:B" & bot & ",H16:H" & bot & ",K16:K" & bot & ",J16:J" & bot & ",I16:I" & bot & ",F16:F" & bot & ",E16:E" & bot & "").Select
' With Selection.Borders(xlEdgeLeft)
' .LineStyle = xlContinuous
' .Weight = xlThin
' End With
'
' With Selection.Borders(xlEdgeTop)
' .LineStyle = xlContinuous
' .Weight = xlThin
' End With
'
' Range("B16:K" & bot).Select
' With Selection.Borders(xlEdgeLeft)
' .LineStyle = xlContinuous
' .Weight = xlThin
' End With
'
' With Selection.Borders(xlEdgeTop)
' .LineStyle = xlContinuous
' .Weight = xlThin
' End With
'
' With Selection.Borders(xlEdgeBottom)
' .LineStyle = xlContinuous
' .Weight = xlThin
' End With
'
' With Selection.Borders(xlEdgeRight)
' .LineStyle = xlContinuous
' .Weight = xlThin
' End With
' w.Range("B16:B" & bot & ",H16:H" & bot & ",K16:K" & bot & ",J16:J" & bot & ",I16:I" & bot & ",F16:F" & bot & ",E16:E" & bot & "").Select
With w.Range("B16:K" & bot)
With .Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlThin
End With
With .Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThin
End With
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
'以下は、内部の軽線引き。 ogawa
With .Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.Weight = xlThin
End With
With .Borders(xlInsideVertical)
.LineStyle = xlContinuous
.Weight = xlThin
End With
End With
End If
Next
' Application.ScreenUpdating = True
End Sub
Sub PrintSet()
'以下の設定は何もマクロで書く必要はありません。
'エクセルのリボンから「ページレイアウト」→「ページ設定ダイアログ」で
'(マクロ自動記録の作業すらなしで)ただ設定しておけばOKです。
'テンプレも少しいじりました。 sub keisen... 内での処理をより簡潔に書くためです。
'シート「main1_matsuisan」をテンプレとした場合と、仕上がりを比べてください。 ogawa
'Print format is set to main1 sheet before it is dulpicated into new sheets
Dim bot As Long
Dim wm1 As Worksheet
Set wm1 = Worksheets("main1")
'wm1.Activate WAS REMOVED PURPOSDFULLY FOR AN ERROR TO SHOW
bot = wm1.Range("B" & Excel.Rows.Count).End(xlUp).Row ' getting the bottom line
Dim prg As Range
Set prg = wm1.Range("A1:K" & bot)
wm1.Activate 'need to acitvate the worksheet including the range you want to select. ogawa
prg.Select
ActiveSheet.PageSetup.PrintArea = prg
With ActiveSheet.PageSetup
.LeftHeader = "&F"
.RightFooter = "&D&T"
.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)
.CenterHorizontally = True
.Orientation = xlLandscape
.PaperSize = xlPaperA4
.FirstPageNumber = xlAutomatic
.Order = xlDownThenOver
.FitToPagesWide = 1
.FitToPagesTall = 1
.ScaleWithDocHeaderFooter = True
End With
End Sub
Sub AllTogether()
'そうそう。この演習では、シート作成実行ボタン、シート削除ボタンも作りますが、
'(せっかくなので、 mainButton シート内にあるボタンももうちょい丁寧に作ってみましょう (^^; ogawa
numbering
sortB
' PrintSet'当該プロシージャ先頭に記載のコメントご確認ください。 ogawa
CreateDenpyo
keisen
sortA
End Sub
'↓モジュールレベル変数を使った共通化例。参考までに。 ogawa
Sub AllTogether_ogawa()
DeleteSheets '←僕ならこのタイミングでやります。「初期化」は、作業開始前に行うべき。 ogawa
numbering
sColSort = "B"
sortOgawa
' PrintSet'当該プロシージャ先頭に記載のコメントご確認ください。 ogawa
CreateDenpyo
keisen
sColSort = "A"
sortOgawa
End Sub
'↓AllTogether_ogawa で呼び出されるもの。 ogawa
Sub sortOgawa()
Dim bot As Long
Dim wm As Worksheet
Set wm = Worksheets("main")
wm.Activate
bot = wm.Range("B" & Excel.Rows.Count).End(xlUp).Row
With ActiveWorkbook.Worksheets("main").Sort
.SortFields.Clear
.SortFields.Add Key:=Range(sColSort & "2:" & sColSort & bot), Order:=xlAscending '←参考にしてください ogawa
.SetRange Range("A1:G" & bot)
.Header = xlYes
.Apply
End With
End Sub
受講生さんの投稿
(投稿ID: 3710) 添付ファイルのダウンロード権限がありません
丁寧な添削いただきありがとうございました。再度、手直ししましたので、ご覧ください。
さて、CreateDenpyoで、左辺に転出先のシートの指定を入れる件ですが、いまいちすっきりした形にできませんでした。なんか長ったらしいいので、スマートにまとめれれば、と思っております。
また、PrintSet, Keisenでもなるたけ対象シートを指定、w.Rangeとか wm1.Rangeとしましたが、エラーになります。とりあえず、activateを入れると走るのでそうしてますが、せっかく明確にシートを指定したのに(VBAが誤解しにくいはず)、逆効果でエラーになるのか、首をひねっています。これもご解説いただけたら幸いです。
よろしくお願いします。
小川慶一さんのコメント
(コメントID: 5225)
こんばんは。
> また、PrintSet, Keisenでもなるたけ対象シートを指定、w.Rangeとか wm1.Rangeとしましたが、エラーになります。とりあえず、activateを入れると走るのでそうしてますが、せっかく明確にシートを指定したのに(VBAが誤解しにくいはず)、逆効果でエラーになるのか、首をひねっています。これもご解説いただけたら幸いです。
↑
これについては、エラーになる(けど、なっとくいかない)状態のマクロをお送りください。
添削は、それをいただいてから、と思います。
よろしくお願いします。
> 小川先生
> 丁寧な添削いただきありがとうございました。再度、手直ししましたので、ご覧ください。
> さて、CreateDenpyoで、左辺に転出先のシートの指定を入れる件ですが、いまいちすっきりした形にできませんでした。なんか長ったらしいいので、スマートにまとめれれば、と思っております。
> また、PrintSet, Keisenでもなるたけ対象シートを指定、w.Rangeとか wm1.Rangeとしましたが、エラーになります。とりあえず、activateを入れると走るのでそうしてますが、せっかく明確にシートを指定したのに(VBAが誤解しにくいはず)、逆効果でエラーになるのか、首をひねっています。これもご解説いただけたら幸いです。
> よろしくお願いします。
松井 憲明さんのコメント
(コメントID: 5233) 添付ファイルのダウンロード権限がありません
小川慶一さんのコメント
(コメントID: 5234)
拝見しました。
セルをアクティブに、またはセレクトするには、事前にその含まれるシートをアクティブにする必要があります。
以下、添削です。