ようやく宿題ができました。まる一日かかってしまいましたが、なんとか動きました。よろしくお願いいたします。 From 岡田 まさこ
option explicit
Sub denpyo_sakusei_homework()
denpyo_sakujo
narabekae
sheetsakusei
End Sub
'以下はそれぞれの部品です。
Sub denpyo_sakujo() '部品1
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 narabekae() '部品2
Dim wfm As Worksheet
Set wfm = Worksheets("main")
wfm.Range("A2").FormulaR1C1 = "1"
wfm.Range("A3").FormulaR1C1 = "2"
wfm.Range("A4").FormulaR1C1 = "3"
wfm.Range("A2:A4").AutoFill Destination:=Range("A2:A317")
wfm.Sort.SortFields.Clear
wfm.Sort.SortFields.Add Key:=Range("B2:B317"), _
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 sheetsakusei() '部品3
Dim wfm As Worksheet
Dim wto As Worksheet
Dim cfm As Long
Dim mx As Long
Dim cto As Long
Set wfm = Worksheets("main")
Set wto = Worksheets("main1")
mx = Range("B" & Rows.Count).End(xlUp).Row
For cfm = 2 To mx
If wfm.Range("B" & cfm).Value <> wfm.Range("B" & cfm - 1).Value Then
If cfm > 2 Then
keisen
End If
Worksheets("main1").Copy After:=Worksheets(Worksheets.Count)
Set wto = ActiveSheet
wto.Name = wfm.Range("B" & cfm).Value
cto = 16
End If
If wto.Name = wfm.Range("B" & cfm).Value Then
wto.Range("E" & cto).Value = wfm.Range("D" & cfm).Value
wto.Range("F" & cto).Value = wfm.Range("E" & cfm).Value
wto.Range("H" & cto).Value = wfm.Range("F" & cfm).Value
wto.Range("J12").Value = wfm.Range("B" & cfm).Value
wto.Range("B" & cto).Value = Right(Year(wfm.Range("C" & cfm).Value), 2)
wto.Range("C" & cto).Value = Month(wfm.Range("C" & cfm).Value)
wto.Range("D" & cto).Value = Day(wfm.Range("C" & cfm).Value)
If wfm.Range("G" & cfm).Value > 0 Then
wto.Range("I" & cto).Value = wfm.Range("G" & cfm).Value
Else
wto.Range("J" & cto).Value = wfm.Range("G" & cfm).Value
End If
Dim c As Range
Set c = wto.Range("K" & cto)
If cto = 16 Then
c = c.Offset(0, -2).Value + c.Offset(0, -1).Value
Else
c = c.Offset(-1, 0).Value + c.Offset(0, -2).Value + c.Offset(0, -1).Value
End If
cto = cto + 1
End If
Next
keisen
Worksheets("main").Activate
wfm.Sort.SortFields.Clear
wfm.Sort.SortFields.Add Key:=Range("A1"), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With wfm.Sort
.SetRange Range("A1:G317")
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Columns("A:A").ClearContents
End Sub
Sub keisen() '部品4
Dim kmx As Long
kmx = Range("K" & Rows.Count).End(xlUp).Row
With Range("B16:K" & kmx + 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 = xlHairline
End With
With .Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlHairline
End With
End With
End Sub
2015/08/17 03:36
小川慶一さんのコメント
(コメントID: 2869)
受講生 さん:
よくできています。添削を返送しますね (^^
Option Explicit
Sub denpyo_sakusei_homework()
'↓わかりやすいです (^^ ogawa
denpyo_sakujo
narabekae
sheetsakusei
End Sub
'以下はそれぞれの部品です。
Sub denpyo_sakujo() '部品1
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 narabekae() '部品2
Dim wfm As Worksheet 'インデントする ogawa
Set wfm = Worksheets("main") 'インデントする ogawa
wfm.Range("A2").FormulaR1C1 = "1"
wfm.Range("A3").FormulaR1C1 = "2"
wfm.Range("A4").FormulaR1C1 = "3"
wfm.Range("A2:A4").AutoFill Destination:=Range("A2:A317")
wfm.Sort.SortFields.Clear
wfm.Sort.SortFields.Add Key:=Range("B2:B317"), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal 'よく書けてます (^^ ogawa
With wfm.Sort
.SetRange Range("A1:G317")
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End Sub
Sub sheetsakusei() '部品3
Dim wfm As Worksheet
Dim wto As Worksheet
Dim cfm As Long
Dim mx As Long
Dim cto As Long
Set wfm = Worksheets("main")
Set wto = Worksheets("main1")
mx = Range("B" & Rows.Count).End(xlUp).Row '一文字左へ ogawa
For cfm = 2 To mx
If wfm.Range("B" & cfm).Value <> wfm.Range("B" & cfm - 1).Value Then
If cfm > 2 Then
keisen
End If
Worksheets("main1").Copy After:=Worksheets(Worksheets.Count)
Set wto = ActiveSheet
wto.Name = wfm.Range("B" & cfm).Value
cto = 16 'インデントする ogawa
End If
If wto.Name = wfm.Range("B" & cfm).Value Then
wto.Range("E" & cto).Value = wfm.Range("D" & cfm).Value
wto.Range("F" & cto).Value = wfm.Range("E" & cfm).Value
wto.Range("H" & cto).Value = wfm.Range("F" & cfm).Value
wto.Range("J12").Value = wfm.Range("B" & cfm).Value
'↓ よく書けてます。さらに、format関数を使った書きなおしもしてみてください (^^ ogawa
wto.Range("B" & cto).Value = Right(Year(wfm.Range("C" & cfm).Value), 2)
wto.Range("C" & cto).Value = Month(wfm.Range("C" & cfm).Value)
wto.Range("D" & cto).Value = Day(wfm.Range("C" & cfm).Value)
If wfm.Range("G" & cfm).Value > 0 Then
wto.Range("I" & cto).Value = wfm.Range("G" & cfm).Value
Else
wto.Range("J" & cto).Value = wfm.Range("G" & cfm).Value
End If
Dim c As Range 'この変数宣言はfornext構文の中でなく、その前に。(理由分かりますか?) ogawa
Set c = wto.Range("K" & cto)
If cto = 16 Then
' c = c.Offset(0, -2).Value + c.Offset(0, -1).Value
c.Value = c.Offset(0, -2).Value + c.Offset(0, -1).Value 'c As Rangeなら、c.Valueでないと。 ogawa
Else
' c = c.Offset(-1, 0).Value + c.Offset(0, -2).Value + c.Offset(0, -1).Value
c.Value = c.Offset(-1, 0).Value + c.Offset(0, -2).Value + c.Offset(0, -1).Value
End If
cto = cto + 1
End If
Next
keisen
Worksheets("main").Activate
wfm.Sort.SortFields.Clear
wfm.Sort.SortFields.Add Key:=Range("A1"), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With wfm.Sort
.SetRange Range("A1:G317")
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Columns("A:A").ClearContents
End Sub
Sub keisen() '部品4
Dim kmx As Long
kmx = Range("K" & Rows.Count).End(xlUp).Row
With Range("B16:K" & kmx + 1) 'Withの使い方上手ですね (^^ ogawa
.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 = xlHairline
End With
With .Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlHairline
End With
End With
End Sub
Sub denpyo_sakusei_homework()
denpyo_sakujo
narabekae
sheetsakusei
End Sub
Sub denpyo_sakujo() '部品1
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 narabekae() '部品2
Dim wfm As Worksheet
Set wfm = Worksheets("main")
wfm.Range("A2").FormulaR1C1 = "1"
wfm.Range("A3").FormulaR1C1 = "2"
wfm.Range("A4").FormulaR1C1 = "3"
wfm.Range("A2:A4").AutoFill Destination:=Range("A2:A317")
wfm.Sort.SortFields.Clear
wfm.Sort.SortFields.Add Key:=Range("B2:B317"), _
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 sheetsakusei() '部品3
Dim wfm As Worksheet
Dim wto As Worksheet
Dim cfm As Long
Dim mx As Long
Dim cto As Long
Dim c As Range
Set wfm = Worksheets("main")
Set wto = Worksheets("main1")
mx = Range("B" & Rows.Count).End(xlUp).Row
For cfm = 2 To mx
If wfm.Range("B" & cfm).Value <> wfm.Range("B" & cfm - 1).Value Then
If cfm > 2 Then
keisen
End If
Worksheets("main1").Copy After:=Worksheets(Worksheets.Count)
Set wto = ActiveSheet
wto.Name = wfm.Range("B" & cfm).Value
cto = 16
End If
If wto.Name = wfm.Range("B" & cfm).Value Then
wto.Range("E" & cto).Value = wfm.Range("D" & cfm).Value
wto.Range("F" & cto).Value = wfm.Range("E" & cfm).Value
wto.Range("H" & cto).Value = wfm.Range("F" & cfm).Value
wto.Range("J12").Value = wfm.Range("B" & cfm).Value
wto.Range("B" & cto).Value = Format((wfm.Range("C" & cfm).Value), "yy")
wto.Range("C" & cto).Value = Format((wfm.Range("C" & cfm).Value), "mm")
wto.Range("D" & cto).Value = Format((wfm.Range("C" & cfm).Value), "dd")
If wfm.Range("G" & cfm).Value > 0 Then
wto.Range("I" & cto).Value = wfm.Range("G" & cfm).Value
Else
wto.Range("J" & cto).Value = wfm.Range("G" & cfm).Value
End If
Set c = wto.Range("K" & cto)
If cto = 16 Then
c.Value = c.Offset(0, -2).Value + c.Offset(0, -1).Value
Else
c.Value = c.Offset(-1, 0).Value + c.Offset(0, -2).Value + c.Offset(0, -1).Value
End If
cto = cto + 1
End If
Next
keisen
Worksheets("main").Activate
wfm.Sort.SortFields.Clear
wfm.Sort.SortFields.Add Key:=Range("A1"), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With wfm.Sort
.SetRange Range("A1:G317")
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Columns("A:A").ClearContents
End Sub
Sub keisen() '部品4
Dim kmx As Long
kmx = Range("K" & Rows.Count).End(xlUp).Row
With Range("B16:K" & kmx + 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 = xlHairline
End With
With .Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlHairline
End With
End With
End Sub
2015/08/31 03:44
小川慶一さんのコメント
(コメントID: 2917)
受講生 さん:
お送りいただいたプログラムは、これでOKかと。 本当にすばらしいです☆
> or next構文の中で変数宣言をしていたのですが、 > それは変数宣言が何度も繰り返されてしまうのでNGなのですか? > プログラムが動いていたので考えがおよびませんでしたが、理由はよくわかりません。
受講生さんの投稿
(投稿ID: 1603)
ようやく宿題ができました。まる一日かかってしまいましたが、なんとか動きました。よろしくお願いいたします。
From 岡田 まさこ
小川慶一さんのコメント
(コメントID: 2869)
よくできています。添削を返送しますね (^^
受講生さんのコメント
(コメントID: 2906)
さっそく添削していただきましてありがとうございました。
ご指摘いただいた箇所を修正してみました。for next構文の中で変数宣言をしていたのですが、それは変数宣言が何度も繰り返されて
しまうのでNGなのですか? プログラムが動いていたので考えがおよびませんでしたが、理由はよくわかりません。
withの使い方をほめていただいたのですが、実は直前に解説をずっと見ていました。。。サラッとかけるように頑張らねば"(-""-)"
先日から上級シリーズのDVDを見始めたのですが、一気に難しくなったような感じがしています。でも、かなり複雑な処理もできそうなので早く習得して実践で使いたいです。いまも時々発展編で習ったことを実践していますが(時間もかかるし、よくエラーでますが)、プログラムが動くととても楽しいです。9月5日の江坂の研修もお邪魔しますのでよろしくお願いします。
岡田 まさこ
小川慶一さんのコメント
(コメントID: 2917)
お送りいただいたプログラムは、これでOKかと。
本当にすばらしいです☆
> or next構文の中で変数宣言をしていたのですが、
> それは変数宣言が何度も繰り返されてしまうのでNGなのですか?
> プログラムが動いていたので考えがおよびませんでしたが、理由はよくわかりません。
↑こびとちゃんの立場になって考えてみてください。
すでにあるものを使いまわすのと、いちいち同じものを作り直すのと。
くり返し作業が例えばそれで1,000万回だったら?大きなコストの違いになりますね。