【宿題】
いつもお世話になります。課題を提出致します。
どうぞ宜しくお願い致します。

Option Explicit
Dim retsu As String

Public Sub create_denpyo()
write_no
retsu = "b" '取引先で並び替え
sort
exe_create_denpyo
retsu = "a" '番号で並び替え
sort
End Sub

Private Sub exe_create_denpyo()
delete_denpyo
Dim infoSh As Worksheet
Dim infoGyo As Long
Dim infoGyoMx As Long
Dim shTo As Worksheet
Dim shtoGyo As Long
Dim dt As Date
Dim sKaisha As String

Set infoSh = Worksheets("main")
infoGyoMx = infoSh.Range("b1048576").End(xlUp).Row

For infoGyo = 2 To infoGyoMx
If sKaisha <> infoSh.Range("b" & infoGyo).Value Then
If infoGyo <> 2 Then
keisen
End If
Worksheets("main1").Copy after:=Worksheets(Worksheets.Count)
Set shTo = ActiveSheet
sKaisha = infoSh.Range("b" & infoGyo).Value
shTo.Name = sKaisha
shtoGyo = 16

End If
'データ転記
shTo.Range("e" & shtoGyo).Value = infoSh.Range("d" & infoGyo).Value
shTo.Range("f" & shtoGyo).Value = infoSh.Range("e" & infoGyo).Value
shTo.Range("h" & shtoGyo).Value = infoSh.Range("f" & infoGyo).Value
If infoSh.Range("g" & infoGyo).Value > 0 Then
shTo.Range("i" & shtoGyo).Value = infoSh.Range("g" & infoGyo).Value
Else
shTo.Range("j" & shtoGyo).Value = infoSh.Range("g" & infoGyo).Value
End If
If shtoGyo = 16 Then
shTo.Range("k" & shtoGyo).Value = infoSh.Range("g" & infoGyo).Value
Else
shTo.Range("k" & shtoGyo).Value = infoSh.Range("g" & infoGyo).Value + shTo.Range("k" & shtoGyo).Offset(-1).Value
End If
dt = infoSh.Range("c" & infoGyo).Value
shTo.Range("b" & shtoGyo).Value = Right(Year(dt), 2)
shTo.Range("c" & shtoGyo).Value = Month(dt)
shTo.Range("d" & shtoGyo).Value = Day(dt)
shtoGyo = shtoGyo + 1
Next
keisen
End Sub

Public Sub delete_denpyo()
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 inMx As Long
inMx = Range("b1048576").End(xlUp).Row

With Range("B16:K" & inMx + 1)
.Borders(xlDiagonalDown).LineStyle = xlNone
.Borders(xlDiagonalUp).LineStyle = xlNone
With .Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = 1
End With
With .Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = 1
End With
With .Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = 1
End With
With .Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = 1
End With
With .Borders(xlInsideVertical)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = 1
End With
With .Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = 1
End With
End With
End Sub

Private Sub sort()
Dim inMx As Long
inMx = Range("b1048576").End(xlUp).Row

Range(retsu & "1").Select
With ActiveWorkbook.Worksheets("main").sort.SortFields
.Clear
.Add _
Key:=Range(retsu & "2:" & retsu & inMx), _
Order:=xlAscending
End With
With ActiveWorkbook.Worksheets("main").sort
.SetRange Range("A1:G" & inMx)
.Header = xlYes
.Apply
End With
End Sub

Private Sub write_no()
Dim inGyo As Long
Dim inMx As Long
inMx = Range("b1048576").End(xlUp).Row

Range("a1").Value = "No."
For inGyo = 2 To inMx
Range("a" & inGyo).Value = inGyo - 1
Next

End Sub

2020/09/28 19:26