小川先生 大変お世話になっております。 添付セミナー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 ------------------------------ 何回も確認をしましたが、エラーの原因究明をうまくできませんでした。 大変お手数ですが、マクロの確認修正をよろしくお願いいたします。 どうぞ、お力を貸していただけますようにお願いします。
2018/01/05 08:51
小川慶一さんのコメント
(コメントID: 5117)
受講生 さん:
'全体によく書けていますね! v(^^*
Sub continue_works()
Call sheet_delete
Call print_form_amend
Call get_number
Call company_name_sort
Call made_denpyo
End Sub
Sub sheet_delete()
Dim ss As Worksheet
Application.DisplayAlerts = False
For Each ss In Worksheets
If Left((ss.Name), 4) <> "main" Then
ss.Delete
End If
Next
Application.DisplayAlerts = True
End Sub
Sub get_number()
Dim ctn As Long
Dim lastrow As Long
lastrow = Worksheets("main").Range("b65536").End(xlUp).Row
For ctn = 2 To lastrow
Worksheets("main").Range("a" & ctn).Value = ctn - 1
Next
Worksheets("main").Range("a1").Value = "No."
End Sub
Sub company_name_sort()
Worksheets("main").Range("A1:G317").Sort _
Key1:=Range("B2"), _
Order1:=xlAscending, _
Header:=xlYes
Range("B1").Select
End Sub
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
'↓シート「main」がアクティブでないので、key1の指定がシート名から必要です。よくあるハマりです。そういう意味では、 company_name_sort の並べ替えも、たまたまうまく言っているだけです。
Worksheets("main").Range("A1:G" & lastrow).Sort _
Key1:=Worksheets("main").Range("a1"), _
Order1:=xlAscending, _
Header:=xlYes
Columns("A:A").Delete
Columns("a:a").Insert
Columns("B:B").ColumnWidth = 10
Columns("a:a").ColumnWidth = 5
End Sub
Private Sub Sort_by_Torihikisaki()
Range("A1:G317").Sort _
Key1:=Range("B1"), _
Order1:=xlAscending, _
Header:=xlYes
End Sub
Private Sub Sort_by_No()
Range("A1:G317").Sort _
Key1:=Range("A1"), _
Order1:=xlAscending, _
Header:=xlYes
End Sub
Sub made_denpyo()
'↓以下のコメント、秀逸! v(^^*
'手順1):main1シートをコピーする
'手順2):新シート名前を取得
'手順3):新シートのrangeB~RangeKまで内容転記
'手順4):ForNextを使って全ての取引先名でシート作成
'手順5):罫線作成
Dim ctn As Long
Dim into As Long
Dim n As String
Dim ss As Worksheet
Dim st As Worksheet
Set st = Worksheets("main")
Dim lastrow As Long
lastrow = Worksheets("main").Range("b65536").End(xlUp).Row
For ctn = 2 To lastrow
'↓If ... End If の間、インデントひとつ少ないです。
If st.Range("b" & ctn).Value <> st.Range("b" & ctn - 1).Value Then
'罫線作成タイミングは新規シート作成手前
If ctn > 2 Then
Call keisen
End If
Sheets("main1").Select
Sheets("main1").Copy After:=Sheets(Sheets.Count)
Set ss = ActiveSheet
n = st.Range("b" & ctn).Value
ss.Name = n
into = 16
End If
ss.Range("e" & into).Value = st.Range("d" & ctn).Value
ss.Range("f" & into).Value = st.Range("e" & ctn).Value
ss.Range("h" & into).Value = st.Range("f" & ctn).Value
If st.Range("g" & ctn).Value > 0 Then
ss.Range("i" & into).Value = st.Range("g" & ctn).Value
Else
ss.Range("j" & into).Value = st.Range("g" & ctn).Value
End If
'↓インデントひとつ余計です。
ss.Range("b" & into).Value = Right(Year(dt), 2)
ss.Range("c" & into).Value = Month(dt)
ss.Range("d" & into).Value = Day(dt)
into = into + 1
Next
Call keisen
Call number_return_delete
End Sub
Sub keisen()
Dim lr As Long
lr = Range("b65536").End(xlUp).Row
'select, selectionがない状態にしたいですね。
Range("B16:K" & lr + 1).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
Sub print_form_amend()
'以下の with ... endwith は、実は、シート「main1」の書式をいじれば不要でした (^^;
With ActiveSheet.PageSetup
.LeftHeader = "&A"
.CenterHeader = ""
.RightHeader = ""
.LeftFooter = "&D"
.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)
End With
Application.PrintCommunication = True
ActiveWindow.View = xlPageLayoutView
ActiveWindow.View = xlPageBreakPreview
ActiveSheet.PageSetup.PrintArea = "$A$1:$M$36"
End Sub
受講生さんの投稿
(投稿ID: 3615) 添付ファイルのダウンロード権限がありません
大変お世話になっております。
添付セミナー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
------------------------------
何回も確認をしましたが、エラーの原因究明をうまくできませんでした。
大変お手数ですが、マクロの確認修正をよろしくお願いいたします。
どうぞ、お力を貸していただけますようにお願いします。
小川慶一さんのコメント
(コメントID: 5117)