小川先生 大変お世話になっております。 ファイルを壊れて申し訳ないです。 内容は下記になります。 Sub continueworks() Call sheetdelet Call getnumber Call companynamesort Call madedenpyo Call numberreturn End Sub Sub sheetdelet() 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 getnumber() Dim bango As Long Dim lastrow As Long lastrow = Range("b65536").End(xlUp).Row For bango = 2 To lastrow Worksheets("main").Range("a" & bango).Value = bango - 1 Next Worksheets("main").Range("a1").Value = "No." End Sub Sub companynamesort() Worksheets("main").Range("A1:G317").Sort _ key1:=Range("b2"), _ Order1:=xlAscending, _ Header:=xlYes Range("B2").Select End Sub Sub numberreturn() Worksheets("main").Range("A1:G317").Sort _ key1:=Range("a2"), _ Order1:=xlAscending, _ Header:=xlYes Range("B2").Select End Sub Sub madedenpyo() '手順1:mainシートをコーピ作成 '手順2:新シート名を付ける '手順3:新シートのRangeB~RnageKまで内容伝記 '手順4:for Nextですべての会社名のシート作成 '手順5:罫線作成 Dim n As String Dim ctn As Long Dim bango As Long Dim lastrow As Long Dim dt As Date Dim st As Worksheet Dim ss As Worksheet Set ss = Worksheets("main") lastrow = ss.Range("b65536").End(xlUp).Row For bango = 2 To lastrow If n <> ss.Range("b" & bango - 1).Value Then If bango > 2 Then '罫線作成タイミングは新規シート追加される手前 Call keisen End If n = ss.Range("b" & bango).Value Sheets("main1").Select Sheets("main1").Copy After:=Sheets(2) Set st = ActiveSheet st.Name = n ctn = 16 End If dt = ss.Range("c" & bango).Value st.Range("e" & ctn).Value = ss.Range("D" & bango).Value st.Range("f" & ctn).Value = ss.Range("e" & bango).Value st.Range("h" & ctn).Value = ss.Range("f" & bango).Value If ss.Range("g" & bango).Value > 0 Then st.Range("i" & ctn).Value = ss.Range("g" & bango).Value Else st.Range("j" & ctn).Value = ss.Range("g" & bango).Value End If
ctn = ctn + 1 Next 'ラスト伝票の罫線作成 Call keisen ss.Activate End Sub
Sub keisen() Dim lr As Long lr = Range("h65536").End(xlUp).Row 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 continueworks() > Call sheetdelet > Call getnumber > Call companynamesort > Call madedenpyo > Call numberreturn > End Sub > Sub sheetdelet() > 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 getnumber() > Dim bango As Long > Dim lastrow As Long > lastrow = Range("b65536").End(xlUp).Row > For bango = 2 To lastrow > Worksheets("main").Range("a" & bango).Value = bango - 1 > Next > Worksheets("main").Range("a1").Value = "No." > End Sub > Sub companynamesort() > Worksheets("main").Range("A1:G317").Sort _ > key1:=Range("b2"), _ > Order1:=xlAscending, _ > Header:=xlYes > Range("B2").Select > End Sub > Sub numberreturn() > Worksheets("main").Range("A1:G317").Sort _ > key1:=Range("a2"), _ > Order1:=xlAscending, _ > Header:=xlYes > Range("B2").Select > End Sub > Sub madedenpyo() > '手順1:mainシートをコーピ作成 > '手順2:新シート名を付ける > '手順3:新シートのRangeB~RnageKまで内容伝記 > '手順4:for Nextですべての会社名のシート作成 > '手順5:罫線作成 > Dim n As String > Dim ctn As Long > Dim bango As Long > Dim lastrow As Long > Dim dt As Date > Dim st As Worksheet > Dim ss As Worksheet > Set ss = Worksheets("main") > lastrow = ss.Range("b65536").End(xlUp).Row > For bango = 2 To lastrow > If n <> ss.Range("b" & bango - 1).Value Then > If bango > 2 Then > '罫線作成タイミングは新規シート追加される手前 > Call keisen > End If > n = ss.Range("b" & bango).Value > Sheets("main1").Select > Sheets("main1").Copy After:=Sheets(2) > Set st = ActiveSheet > st.Name = n > ctn = 16 > End If > dt = ss.Range("c" & bango).Value > st.Range("e" & ctn).Value = ss.Range("D" & bango).Value > st.Range("f" & ctn).Value = ss.Range("e" & bango).Value > st.Range("h" & ctn).Value = ss.Range("f" & bango).Value > If ss.Range("g" & bango).Value > 0 Then > st.Range("i" & ctn).Value = ss.Range("g" & bango).Value > Else > st.Range("j" & ctn).Value = ss.Range("g" & bango).Value > End If > > st.Range("b" & ctn).Value = Right(Year(dt), 2) > st.Range("c" & ctn).Value = Month(dt) > st.Range("d" & ctn).Value = Day(dt) > > ctn = ctn + 1 > Next > 'ラスト伝票の罫線作成 > Call keisen > ss.Activate > End Sub > > Sub keisen() > Dim lr As Long > lr = Range("h65536").End(xlUp).Row > 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 > > > > 大変お手数ですが、どうぞよろしくお願いいたします。
受講生さんの投稿
(投稿ID: 3616) 添付ファイルのダウンロード権限がありません
大変お世話になっております。
ファイルを壊れて申し訳ないです。
内容は下記になります。
Sub continueworks()
Call sheetdelet
Call getnumber
Call companynamesort
Call madedenpyo
Call numberreturn
End Sub
Sub sheetdelet()
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 getnumber()
Dim bango As Long
Dim lastrow As Long
lastrow = Range("b65536").End(xlUp).Row
For bango = 2 To lastrow
Worksheets("main").Range("a" & bango).Value = bango - 1
Next
Worksheets("main").Range("a1").Value = "No."
End Sub
Sub companynamesort()
Worksheets("main").Range("A1:G317").Sort _
key1:=Range("b2"), _
Order1:=xlAscending, _
Header:=xlYes
Range("B2").Select
End Sub
Sub numberreturn()
Worksheets("main").Range("A1:G317").Sort _
key1:=Range("a2"), _
Order1:=xlAscending, _
Header:=xlYes
Range("B2").Select
End Sub
Sub madedenpyo()
'手順1:mainシートをコーピ作成
'手順2:新シート名を付ける
'手順3:新シートのRangeB~RnageKまで内容伝記
'手順4:for Nextですべての会社名のシート作成
'手順5:罫線作成
Dim n As String
Dim ctn As Long
Dim bango As Long
Dim lastrow As Long
Dim dt As Date
Dim st As Worksheet
Dim ss As Worksheet
Set ss = Worksheets("main")
lastrow = ss.Range("b65536").End(xlUp).Row
For bango = 2 To lastrow
If n <> ss.Range("b" & bango - 1).Value Then
If bango > 2 Then
'罫線作成タイミングは新規シート追加される手前
Call keisen
End If
n = ss.Range("b" & bango).Value
Sheets("main1").Select
Sheets("main1").Copy After:=Sheets(2)
Set st = ActiveSheet
st.Name = n
ctn = 16
End If
dt = ss.Range("c" & bango).Value
st.Range("e" & ctn).Value = ss.Range("D" & bango).Value
st.Range("f" & ctn).Value = ss.Range("e" & bango).Value
st.Range("h" & ctn).Value = ss.Range("f" & bango).Value
If ss.Range("g" & bango).Value > 0 Then
st.Range("i" & ctn).Value = ss.Range("g" & bango).Value
Else
st.Range("j" & ctn).Value = ss.Range("g" & bango).Value
End If
st.Range("b" & ctn).Value = Right(Year(dt), 2)
st.Range("c" & ctn).Value = Month(dt)
st.Range("d" & ctn).Value = Day(dt)
ctn = ctn + 1
Next
'ラスト伝票の罫線作成
Call keisen
ss.Activate
End Sub
Sub keisen()
Dim lr As Long
lr = Range("h65536").End(xlUp).Row
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
大変お手数ですが、どうぞよろしくお願いいたします。
小川慶一さんのコメント
(コメントID: 5118)
こっちは、さっき回答差し上げたものと同じでしょうか?
であれば、回答省略します。もし何かあればお知らせください!
> 小川先生
> 大変お世話になっております。
> ファイルを壊れて申し訳ないです。
> 内容は下記になります。
> Sub continueworks()
> Call sheetdelet
> Call getnumber
> Call companynamesort
> Call madedenpyo
> Call numberreturn
> End Sub
> Sub sheetdelet()
> 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 getnumber()
> Dim bango As Long
> Dim lastrow As Long
> lastrow = Range("b65536").End(xlUp).Row
> For bango = 2 To lastrow
> Worksheets("main").Range("a" & bango).Value = bango - 1
> Next
> Worksheets("main").Range("a1").Value = "No."
> End Sub
> Sub companynamesort()
> Worksheets("main").Range("A1:G317").Sort _
> key1:=Range("b2"), _
> Order1:=xlAscending, _
> Header:=xlYes
> Range("B2").Select
> End Sub
> Sub numberreturn()
> Worksheets("main").Range("A1:G317").Sort _
> key1:=Range("a2"), _
> Order1:=xlAscending, _
> Header:=xlYes
> Range("B2").Select
> End Sub
> Sub madedenpyo()
> '手順1:mainシートをコーピ作成
> '手順2:新シート名を付ける
> '手順3:新シートのRangeB~RnageKまで内容伝記
> '手順4:for Nextですべての会社名のシート作成
> '手順5:罫線作成
> Dim n As String
> Dim ctn As Long
> Dim bango As Long
> Dim lastrow As Long
> Dim dt As Date
> Dim st As Worksheet
> Dim ss As Worksheet
> Set ss = Worksheets("main")
> lastrow = ss.Range("b65536").End(xlUp).Row
> For bango = 2 To lastrow
> If n <> ss.Range("b" & bango - 1).Value Then
> If bango > 2 Then
> '罫線作成タイミングは新規シート追加される手前
> Call keisen
> End If
> n = ss.Range("b" & bango).Value
> Sheets("main1").Select
> Sheets("main1").Copy After:=Sheets(2)
> Set st = ActiveSheet
> st.Name = n
> ctn = 16
> End If
> dt = ss.Range("c" & bango).Value
> st.Range("e" & ctn).Value = ss.Range("D" & bango).Value
> st.Range("f" & ctn).Value = ss.Range("e" & bango).Value
> st.Range("h" & ctn).Value = ss.Range("f" & bango).Value
> If ss.Range("g" & bango).Value > 0 Then
> st.Range("i" & ctn).Value = ss.Range("g" & bango).Value
> Else
> st.Range("j" & ctn).Value = ss.Range("g" & bango).Value
> End If
>
> st.Range("b" & ctn).Value = Right(Year(dt), 2)
> st.Range("c" & ctn).Value = Month(dt)
> st.Range("d" & ctn).Value = Day(dt)
>
> ctn = ctn + 1
> Next
> 'ラスト伝票の罫線作成
> Call keisen
> ss.Activate
> End Sub
>
> Sub keisen()
> Dim lr As Long
> lr = Range("h65536").End(xlUp).Row
> 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
>
>
>
> 大変お手数ですが、どうぞよろしくお願いいたします。