Option Explicit
Dim Retsu As String
Sub CreateDenpyo()
Application.ScreenUpdating = False
NumberingA
Retsu = "B"
Sorting
ExeCreateDenpyo
Retsu = "A"
Sorting
Application.ScreenUpdating = True
End Sub
Sub NumberingA() 'シート"main"のA列に順番に番号を付けて行くマクロ
Dim lngMax As Long 'シート"main"の最大行数を入れる
Dim lngGyo As Long
lngMax = Worksheets("main").Range("B" & Rows.Count).End(xlUp).Row
Range("A1").Value = "No."
For lngGyo = 2 To lngMax
Range("A" & lngGyo).Value = lngGyo - 1
Next
End Sub
Sub Sorting()
Dim lngMax As Long 'シート"main"の最大行数を入れる
lngMax = Worksheets("main").Range("B" & Rows.Count).End(xlUp).Row
ActiveWorkbook.Worksheets("main").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("main").Sort.SortFields.Add _
Key:=Range(Retsu & "2:" & Retsu & lngMax), _
SortOn:=xlSortOnValues, _
Order:=xlAscending, _
DataOption:=xlSortNormal
With Worksheets("main").Sort
.SetRange Range("A1:G" & lngMax)
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Range("A1").Select
End Sub
Sub ExeCreateDenpyo()
'シート"main"のB列のデータの値によって、
'シート作成(シート"main1"のコピー)、シート名付与、データ転記するマクロ
Dim lngMax As Long 'シート"main"の最大行数を入れる
Dim st As String 'シート名(取引先名称)を入れる
Dim lngFm As Long
Dim lngTo As Long
Dim shtFm As Worksheet
Dim shtTo As Worksheet
DeleteDenpyo
Set shtFm = Worksheets("main")
shtFm.Activate
lngMax = shtFm.Range("B" & Rows.Count).End(xlUp).Row
For lngFm = 2 To lngMax
If st <> shtFm.Range("B" & lngFm).Value Then
If lngFm > 2 Then
Keisen
End If
st = shtFm.Range("B" & lngFm).Value
Worksheets("main1").Copy After:=Worksheets(Worksheets.Count) 'コピー
Set shtTo = ActiveSheet
shtTo.Name = st 'シート名付与
lngTo = 16
End If
'ここからデータ転記
shtTo.Range("B" & lngTo).Value = Right(Year(shtFm.Range("C" & lngFm).Value), 2)
shtTo.Range("C" & lngTo).Value = Month(shtFm.Range("C" & lngFm).Value)
shtTo.Range("D" & lngTo).Value = Day(shtFm.Range("C" & lngFm).Value)
shtTo.Range("E" & lngTo).Value = shtFm.Range("D" & lngFm).Value
shtTo.Range("F" & lngTo).Value = shtFm.Range("E" & lngFm).Value
shtTo.Range("H" & lngTo).Value = shtFm.Range("F" & lngFm).Value
If shtFm.Range("G" & lngFm).Value > 0 Then
shtTo.Range("I" & lngTo).Value = shtFm.Range("G" & lngFm).Value
Else
shtTo.Range("J" & lngTo).Value = shtFm.Range("G" & lngFm).Value
End If
If lngTo = 16 Then
shtTo.Range("K" & lngTo).Value = shtTo.Range("I" & lngTo).Value + shtTo.Range("J" & lngTo).Value
Else
shtTo.Range("K" & lngTo).Value = shtTo.Range("I" & lngTo).Value + shtTo.Range("J" & lngTo).Value + shtTo.Range("K" & lngTo).Offset(-1).Value
End If
lngTo = lngTo + 1
Next
Keisen
Worksheets("main").Select
End Sub
Sub DeleteDenpyo()
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 Keisen()
Dim lngMax2 As Long
lngMax2 = ActiveSheet.Range("B" & Rows.Count).End(xlUp).Row
ActiveSheet.Range("B16:K" & lngMax2 + 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 = xlHairline
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlHairline
End With
Range("A1").Activate
End Sub
Option Explicit
'以下の運用であれば適切です v(^^* ogawa
Dim Retsu As String
Sub CreateDenpyo()
Application.ScreenUpdating = False
NumberingA
Retsu = "B"
Sorting
ExeCreateDenpyo
Retsu = "A"
Sorting
Application.ScreenUpdating = True
End Sub
Sub NumberingA() 'シート"main"のA列に順番に番号を付けて行くマクロ
'OKです。以下では、autofillを使った方法も検討してみてください ogawa
Dim lngMax As Long 'シート"main"の最大行数を入れる
Dim lngGyo As Long
lngMax = Worksheets("main").Range("B" & Rows.Count).End(xlUp).Row
Range("A1").Value = "No."
For lngGyo = 2 To lngMax
Range("A" & lngGyo).Value = lngGyo - 1
Next
End Sub
Sub Sorting()
Dim lngMax As Long 'シート"main"の最大行数を入れる
lngMax = Worksheets("main").Range("B" & Rows.Count).End(xlUp).Row
ActiveWorkbook.Worksheets("main").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("main").Sort.SortFields.Add _
Key:=Range(Retsu & "2:" & Retsu & lngMax), _
SortOn:=xlSortOnValues, _
Order:=xlAscending, _
DataOption:=xlSortNormal
With Worksheets("main").Sort
.SetRange Range("A1:G" & lngMax)
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Range("A1").Select
End Sub
Sub ExeCreateDenpyo()
'シート"main"のB列のデータの値によって、
'シート作成(シート"main1"のコピー)、シート名付与、データ転記するマクロ
Dim lngMax As Long 'シート"main"の最大行数を入れる
Dim st As String 'シート名(取引先名称)を入れる
Dim lngFm As Long
Dim lngTo As Long
Dim shtFm As Worksheet
Dim shtTo As Worksheet
DeleteDenpyo
Set shtFm = Worksheets("main")
shtFm.Activate
lngMax = shtFm.Range("B" & Rows.Count).End(xlUp).Row
Dim dt As Date 'ogawa
For lngFm = 2 To lngMax
If st <> shtFm.Range("B" & lngFm).Value Then
If lngFm > 2 Then
Keisen
End If
st = shtFm.Range("B" & lngFm).Value
Worksheets("main1").Copy After:=Worksheets(Worksheets.Count) 'コピー
Set shtTo = ActiveSheet
shtTo.Name = st 'シート名付与
lngTo = 16
End If
'ここからデータ転記
' shtTo.Range("B" & lngTo).Value = Right(Year(shtFm.Range("C" & lngFm).Value), 2)
' shtTo.Range("C" & lngTo).Value = Month(shtFm.Range("C" & lngFm).Value)
' shtTo.Range("D" & lngTo).Value = Day(shtFm.Range("C" & lngFm).Value)
'format関数を使った例です↓ ogawa
dt = shtFm.Range("C" & lngFm).Value
shtTo.Range("B" & lngTo).Value = Format(dt, "yy")
shtTo.Range("C" & lngTo).Value = Format(dt, "mm")
shtTo.Range("D" & lngTo).Value = Format(dt, "dd")
shtTo.Range("E" & lngTo).Value = shtFm.Range("D" & lngFm).Value
shtTo.Range("F" & lngTo).Value = shtFm.Range("E" & lngFm).Value
shtTo.Range("H" & lngTo).Value = shtFm.Range("F" & lngFm).Value
If shtFm.Range("G" & lngFm).Value > 0 Then
shtTo.Range("I" & lngTo).Value = shtFm.Range("G" & lngFm).Value
Else
shtTo.Range("J" & lngTo).Value = shtFm.Range("G" & lngFm).Value
End If
If lngTo = 16 Then
shtTo.Range("K" & lngTo).Value = shtTo.Range("I" & lngTo).Value + shtTo.Range("J" & lngTo).Value
Else
shtTo.Range("K" & lngTo).Value = shtTo.Range("I" & lngTo).Value + shtTo.Range("J" & lngTo).Value + shtTo.Range("K" & lngTo).Offset(-1).Value 'Offsetを使うのもよいですね ogawa
End If
lngTo = lngTo + 1
Next
Keisen
Worksheets("main").Select
End Sub
Sub DeleteDenpyo()
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 Keisen()
Dim lngMax2 As Long
lngMax2 = ActiveSheet.Range("B" & Rows.Count).End(xlUp).Row
'以下では、 selection. select という言葉が登場しないようにすることも可能です。さらにリライトを!! ogawa
ActiveSheet.Range("B16:K" & lngMax2 + 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 = xlHairline
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlHairline
End With
Range("A1").Activate
End Sub
Option Explicit
Dim Retsu As String
'シート"main"のデータを基に伝票を作成するマクロを作れ
'シート"main1"は伝票のテンプレート
Sub CreateDenpyo()
NumberingA
Retsu = "B"
Sorting
ExeCreateDenpyo
Retsu = "A"
Sorting
End Sub
Sub NumberingA()
Dim lngMax As Long
lngMax = Range("B" & Rows.Count).End(xlUp).Row
Range("A1").Value = "No."
Range("A2").Value = 1
Range("A2").AutoFill Destination:=Range("A2:A" & lngMax), Type:=xlFillSeries
End Sub
Sub Sorting()
Dim lngMax As Long
lngMax = Range("B" & Rows.Count).End(xlUp).Row
Worksheets("main").Sort.SortFields.Clear
Worksheets("main").Sort.SortFields.Add Key:=Range(Retsu & "2:" & Retsu & lngMax), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("main").Sort
.SetRange Range("A1:G" & lngMax)
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End Sub
Sub ExeCreateDenpyo()
Dim lngMax As Long
Dim shtFm As Worksheet
Dim shtTo As Worksheet
Dim lngTo As Long
Dim lngFm As Long
Dim st As String
Dim dt As Date
DeleteDenpyo
'B列の値が違ったらシートを追加する
Set shtFm = Worksheets("main")
lngMax = shtFm.Range("B" & Rows.Count).End(xlUp).Row
For lngFm = 2 To lngMax
If shtFm.Range("B" & lngFm).Value <> st Then
If lngFm > 2 Then
Keisen
End If
st = shtFm.Range("B" & lngFm).Value
Worksheets("main1").Copy After:=Worksheets(Worksheets.Count)
Set shtTo = ActiveSheet
shtTo.Name = st
lngTo = 16
End If
'データの転記
dt = shtFm.Range("C" & lngFm).Value
shtTo.Range("B" & lngTo).Value = Format(dt, "yy")
shtTo.Range("C" & lngTo).Value = Format(dt, "mm")
shtTo.Range("D" & lngTo).Value = Format(dt, "dd")
shtTo.Range("E" & lngTo).Value = shtFm.Range("D" & lngFm).Value
shtTo.Range("F" & lngTo).Value = shtFm.Range("E" & lngFm).Value
shtTo.Range("H" & lngTo).Value = shtFm.Range("F" & lngFm).Value
If shtFm.Range("G" & lngFm).Value > 0 Then
shtTo.Range("I" & lngTo).Value = shtFm.Range("G" & lngFm).Value
Else
shtTo.Range("J" & lngTo).Value = shtFm.Range("G" & lngFm).Value
End If
If lngTo = 16 Then
shtTo.Range("K" & lngTo).Value = shtTo.Range("I" & lngTo).Value + shtTo.Range("J" & lngTo).Value
Else
shtTo.Range("K" & lngTo).Value = shtTo.Range("I" & lngTo).Value + shtTo.Range("J" & lngTo).Value + shtTo.Range("K" & lngTo).Offset(-1).Value
End If
lngTo = lngTo + 1
Next
Keisen
shtFm.Activate
End Sub
Sub DeleteDenpyo()
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 Keisen()
Dim lngMx2 As Long
Dim Rg As Range
lngMx2 = ActiveSheet.Range("B" & Rows.Count).End(xlUp).Row
Set Rg = ActiveSheet.Range("B16:K" & lngMx2 + 1)
Rg.Borders(xlDiagonalDown).LineStyle = xlNone
Rg.Borders(xlDiagonalUp).LineStyle = xlNone
With Rg.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Rg.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Rg.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Rg.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Rg.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlHairline
End With
With Rg.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlHairline
End With
End Sub
2018/07/29 21:45
小川慶一さんのコメント
(コメントID: 5598)
のんのんさん:
添削を返送します。
何度か書いてみて、かなり慣れましたでしょうか。
Option Explicit
Dim Retsu As String
'シート"main"のデータを基に伝票を作成するマクロを作れ
'シート"main1"は伝票のテンプレート
Sub CreateDenpyo()
NumberingA
Retsu = "B"
Sorting
ExeCreateDenpyo 'application.screenupdatingの設定を切り替えることでより高速化できます ogawa
Retsu = "A"
Sorting
End Sub
Sub NumberingA()
Dim lngMax As Long
lngMax = Range("B" & Rows.Count).End(xlUp).Row
Range("A1").Value = "No."
Range("A2").Value = 1
Range("A2").AutoFill Destination:=Range("A2:A" & lngMax), Type:=xlFillSeries
'↑excellent!! autofill のほうが状況によっては高速です☆ ogawa
End Sub
Sub Sorting()
Dim lngMax As Long
lngMax = Range("B" & Rows.Count).End(xlUp).Row
'↓実はもっと with を使って効率よく書けます。重複している言葉は何? ogawa
Worksheets("main").Sort.SortFields.Clear
Worksheets("main").Sort.SortFields.Add Key:=Range(Retsu & "2:" & Retsu & lngMax), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("main").Sort
.SetRange Range("A1:G" & lngMax)
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End Sub
Sub ExeCreateDenpyo()
Dim lngMax As Long
Dim shtFm As Worksheet
Dim shtTo As Worksheet
Dim lngTo As Long
Dim lngFm As Long
Dim st As String
Dim dt As Date
DeleteDenpyo
'B列の値が違ったらシートを追加する
Set shtFm = Worksheets("main")
lngMax = shtFm.Range("B" & Rows.Count).End(xlUp).Row
For lngFm = 2 To lngMax
If shtFm.Range("B" & lngFm).Value <> st Then
If lngFm > 2 Then
Keisen
End If
st = shtFm.Range("B" & lngFm).Value
Worksheets("main1").Copy After:=Worksheets(Worksheets.Count)
Set shtTo = ActiveSheet
shtTo.Name = st
lngTo = 16
End If
'データの転記
dt = shtFm.Range("C" & lngFm).Value
shtTo.Range("B" & lngTo).Value = Format(dt, "yy")
shtTo.Range("C" & lngTo).Value = Format(dt, "mm")
shtTo.Range("D" & lngTo).Value = Format(dt, "dd")
shtTo.Range("E" & lngTo).Value = shtFm.Range("D" & lngFm).Value
shtTo.Range("F" & lngTo).Value = shtFm.Range("E" & lngFm).Value
shtTo.Range("H" & lngTo).Value = shtFm.Range("F" & lngFm).Value
If shtFm.Range("G" & lngFm).Value > 0 Then
shtTo.Range("I" & lngTo).Value = shtFm.Range("G" & lngFm).Value
Else
shtTo.Range("J" & lngTo).Value = shtFm.Range("G" & lngFm).Value
End If
If lngTo = 16 Then
shtTo.Range("K" & lngTo).Value = shtTo.Range("I" & lngTo).Value + shtTo.Range("J" & lngTo).Value
Else
shtTo.Range("K" & lngTo).Value = shtTo.Range("I" & lngTo).Value + shtTo.Range("J" & lngTo).Value + shtTo.Range("K" & lngTo).Offset(-1).Value
End If
lngTo = lngTo + 1
Next
Keisen
shtFm.Activate
End Sub
Sub DeleteDenpyo()
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 Keisen()
Dim lngMx2 As Long
Dim Rg As Range
lngMx2 = ActiveSheet.Range("B" & Rows.Count).End(xlUp).Row
Set Rg = ActiveSheet.Range("B16:K" & lngMx2 + 1)
Rg.Borders(xlDiagonalDown).LineStyle = xlNone
Rg.Borders(xlDiagonalUp).LineStyle = xlNone
With Rg.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Rg.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Rg.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Rg.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Rg.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlHairline
End With
With Rg.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlHairline
End With
End Sub
> こんにちは。 > リライトしました。よろしくお願いいたします。 > >
> Option Explicit
>
> Dim Retsu As String
> 'シート"main"のデータを基に伝票を作成するマクロを作れ
> 'シート"main1"は伝票のテンプレート
> Sub CreateDenpyo()
> NumberingA
> Retsu = "B"
> Sorting
> ExeCreateDenpyo
> Retsu = "A"
> Sorting
> End Sub
>
> Sub NumberingA()
> Dim lngMax As Long
>
> lngMax = Range("B" & Rows.Count).End(xlUp).Row
> Range("A1").Value = "No."
> Range("A2").Value = 1
> Range("A2").AutoFill Destination:=Range("A2:A" & lngMax), Type:=xlFillSeries
> End Sub
>
> Sub Sorting()
> Dim lngMax As Long
>
> lngMax = Range("B" & Rows.Count).End(xlUp).Row
> Worksheets("main").Sort.SortFields.Clear
> Worksheets("main").Sort.SortFields.Add Key:=Range(Retsu & "2:" & Retsu & lngMax), _
> SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
> With ActiveWorkbook.Worksheets("main").Sort
> .SetRange Range("A1:G" & lngMax)
> .Header = xlYes
> .MatchCase = False
> .Orientation = xlTopToBottom
> .SortMethod = xlPinYin
> .Apply
> End With
> End Sub
>
> Sub ExeCreateDenpyo()
> Dim lngMax As Long
> Dim shtFm As Worksheet
> Dim shtTo As Worksheet
> Dim lngTo As Long
> Dim lngFm As Long
> Dim st As String
> Dim dt As Date
>
> DeleteDenpyo
> 'B列の値が違ったらシートを追加する
> Set shtFm = Worksheets("main")
>
> lngMax = shtFm.Range("B" & Rows.Count).End(xlUp).Row
> For lngFm = 2 To lngMax
> If shtFm.Range("B" & lngFm).Value <> st Then
> If lngFm > 2 Then
> Keisen
> End If
> st = shtFm.Range("B" & lngFm).Value
> Worksheets("main1").Copy After:=Worksheets(Worksheets.Count)
> Set shtTo = ActiveSheet
> shtTo.Name = st
> lngTo = 16
> End If
>
> 'データの転記
> dt = shtFm.Range("C" & lngFm).Value
> shtTo.Range("B" & lngTo).Value = Format(dt, "yy")
> shtTo.Range("C" & lngTo).Value = Format(dt, "mm")
> shtTo.Range("D" & lngTo).Value = Format(dt, "dd")
> shtTo.Range("E" & lngTo).Value = shtFm.Range("D" & lngFm).Value
> shtTo.Range("F" & lngTo).Value = shtFm.Range("E" & lngFm).Value
> shtTo.Range("H" & lngTo).Value = shtFm.Range("F" & lngFm).Value
> If shtFm.Range("G" & lngFm).Value > 0 Then
> shtTo.Range("I" & lngTo).Value = shtFm.Range("G" & lngFm).Value
> Else
> shtTo.Range("J" & lngTo).Value = shtFm.Range("G" & lngFm).Value
> End If
> If lngTo = 16 Then
> shtTo.Range("K" & lngTo).Value = shtTo.Range("I" & lngTo).Value + shtTo.Range("J" & lngTo).Value
> Else
> shtTo.Range("K" & lngTo).Value = shtTo.Range("I" & lngTo).Value + shtTo.Range("J" & lngTo).Value + shtTo.Range("K" & lngTo).Offset(-1).Value
> End If
> lngTo = lngTo + 1
> Next
> Keisen
> shtFm.Activate
> End Sub
>
> Sub DeleteDenpyo()
> 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 Keisen()
> Dim lngMx2 As Long
> Dim Rg As Range
>
> lngMx2 = ActiveSheet.Range("B" & Rows.Count).End(xlUp).Row
>
> Set Rg = ActiveSheet.Range("B16:K" & lngMx2 + 1)
> Rg.Borders(xlDiagonalDown).LineStyle = xlNone
> Rg.Borders(xlDiagonalUp).LineStyle = xlNone
> With Rg.Borders(xlEdgeLeft)
> .LineStyle = xlContinuous
> .ColorIndex = 0
> .TintAndShade = 0
> .Weight = xlThin
> End With
> With Rg.Borders(xlEdgeTop)
> .LineStyle = xlContinuous
> .ColorIndex = 0
> .TintAndShade = 0
> .Weight = xlThin
> End With
> With Rg.Borders(xlEdgeBottom)
> .LineStyle = xlContinuous
> .ColorIndex = 0
> .TintAndShade = 0
> .Weight = xlThin
> End With
> With Rg.Borders(xlEdgeRight)
> .LineStyle = xlContinuous
> .ColorIndex = 0
> .TintAndShade = 0
> .Weight = xlThin
> End With
> With Rg.Borders(xlInsideVertical)
> .LineStyle = xlContinuous
> .ColorIndex = 0
> .TintAndShade = 0
> .Weight = xlHairline
> End With
> With Rg.Borders(xlInsideHorizontal)
> .LineStyle = xlContinuous
> .ColorIndex = 0
> .TintAndShade = 0
> .Weight = xlHairline
> End With
> End Sub
>
Option Explicit
Dim Retsu As String
'シート"main"のデータを基に伝票を作成するマクロを作れ
'シート"main1"は伝票のテンプレート
Sub CreateDenpyo()
NumberingA
Retsu = "B"
Sorting
ExeCreateDenpyo
Retsu = "A"
Sorting
End Sub
Sub NumberingA()
Dim lngMax As Long
lngMax = Range("B" & Rows.Count).End(xlUp).Row
Range("A1").Value = "No."
Range("A2").Value = 1
Range("A2").AutoFill Destination:=Range("A2:A" & lngMax), Type:=xlFillSeries
End Sub
Sub Sorting()
Dim lngMax As Long
lngMax = Range("B" & Rows.Count).End(xlUp).Row
With Worksheets("main").Sort
.SortFields.Clear
.SortFields.Add Key:=Range(Retsu & "2:" & Retsu & lngMax), _
SortOn:=xlSortOnValues, _
Order:=xlAscending, _
DataOption:=xlSortNormal
.SetRange Range("A1:G" & lngMax)
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End Sub
Sub ExeCreateDenpyo()
Dim lngMax As Long
Dim shtFm As Worksheet
Dim shtTo As Worksheet
Dim lngTo As Long
Dim lngFm As Long
Dim st As String
Dim dt As Date
DeleteDenpyo
Application.ScreenUpdating = False
'B列の値が違ったらシートを追加する
Set shtFm = Worksheets("main")
lngMax = shtFm.Range("B" & Rows.Count).End(xlUp).Row
For lngFm = 2 To lngMax
If shtFm.Range("B" & lngFm).Value <> st Then
If lngFm > 2 Then
Keisen
End If
st = shtFm.Range("B" & lngFm).Value
Worksheets("main1").Copy After:=Worksheets(Worksheets.Count)
Set shtTo = ActiveSheet
shtTo.Name = st
lngTo = 16
End If
'データの転記
dt = shtFm.Range("C" & lngFm).Value
shtTo.Range("B" & lngTo).Value = Format(dt, "yy")
shtTo.Range("C" & lngTo).Value = Format(dt, "mm")
shtTo.Range("D" & lngTo).Value = Format(dt, "dd")
shtTo.Range("E" & lngTo).Value = shtFm.Range("D" & lngFm).Value
shtTo.Range("F" & lngTo).Value = shtFm.Range("E" & lngFm).Value
shtTo.Range("H" & lngTo).Value = shtFm.Range("F" & lngFm).Value
If shtFm.Range("G" & lngFm).Value > 0 Then
shtTo.Range("I" & lngTo).Value = shtFm.Range("G" & lngFm).Value
Else
shtTo.Range("J" & lngTo).Value = shtFm.Range("G" & lngFm).Value
End If
If lngTo = 16 Then
shtTo.Range("K" & lngTo).Value = shtTo.Range("I" & lngTo).Value + shtTo.Range("J" & lngTo).Value
Else
shtTo.Range("K" & lngTo).Value = shtTo.Range("I" & lngTo).Value + shtTo.Range("J" & lngTo).Value + shtTo.Range("K" & lngTo).Offset(-1).Value
End If
lngTo = lngTo + 1
Next
Keisen
shtFm.Activate
Application.ScreenUpdating = True
End Sub
Sub DeleteDenpyo()
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 Keisen()
Dim lngMx2 As Long
Dim Rg As Range
lngMx2 = ActiveSheet.Range("B" & Rows.Count).End(xlUp).Row
Set Rg = ActiveSheet.Range("B16:K" & lngMx2 + 1)
Rg.Borders(xlDiagonalDown).LineStyle = xlNone
Rg.Borders(xlDiagonalUp).LineStyle = xlNone
With Rg.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Rg.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Rg.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Rg.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Rg.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlHairline
End With
With Rg.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlHairline
End With
End Sub
のんのんさんの投稿
(投稿ID: 4032)
よろしくお願いします☆
前回の添削で、1か所理解できないところがありました。
「'↓Format関数の活用も検討してください。ogawa」
のところですが、これは rowAnumberingサブプロシージャのどこで Format関数を使えばよいのでしょうか?
よろしくお願いします。
小川慶一さんのコメント
(コメントID: 5591)
添削返送します。
だいぶブラッシュアップされましたね!
> 「'↓Format関数の活用も検討してください。ogawa」
> のところですが、これは rowAnumberingサブプロシージャのどこで Format関数を使えばよいのでしょうか?
> よろしくお願いします。
↑添削をご確認ください☆
> 再提出します。
> よろしくお願いします☆
>
> 前回の添削で、1か所理解できないところがありました。
>
> 「'↓Format関数の活用も検討してください。ogawa」
> のところですが、これは rowAnumberingサブプロシージャのどこで Format関数を使えばよいのでしょうか?
> よろしくお願いします。
>
のんのんさんのコメント
(コメントID: 5594)
リライトしました。よろしくお願いいたします。
小川慶一さんのコメント
(コメントID: 5598)
添削を返送します。
何度か書いてみて、かなり慣れましたでしょうか。
> こんにちは。
> リライトしました。よろしくお願いいたします。
>
>
のんのんさんのコメント
(コメントID: 5603)
Sorting、Withを使った表現にリライトしました。
Application.Screenupdatingも追記しました。
よろしくお願いいたします。
小川慶一さんのコメント
(コメントID: 5604)
おはようございます。
発展編1レベルの演習としては、手直しはこのくらいでも十分すぎるかと思います v(^^*
イチから書いてもこのくらいのクオリティのものを書けるよう、さらに練習してください☆
> こんにちは。
> Sorting、Withを使った表現にリライトしました。
> Application.Screenupdatingも追記しました。
> よろしくお願いいたします。
>
>