【マクロ】あいうえお順のシートに振分けしたい

Question

マクロ初心者です。よろしくお願いします。

B列⇒品名、C列⇒型式、D列⇒価格で、追加入力はB列の一番下にしていきます。

【やりたい事】
品名でフィルターをかけたものを別シート『あ』～『Z』に貼り付けたい。
（添付画像は昇順で並べ替えてあります）
A～Zで始まる品名は『読み』は無視してあくまでA、B…の表示優先です。

商品の追加は不定期で、マクロをかけるタイミングもまちまちですので
前の別シート『あ』～『Z』のデータは上書きして構いません。


不明な点などありましたらご指摘ください。
お手数かけますが、よろしくお願いします。

WindFaller · Accepted Answer

#6の回答者です。

試していただいてありがとうございます。
ともかく、エラーを出さないためには、データとシートの両方のチェックができていれば、8割方問題は発生しないのです。

>走らせてみましたら、『ガ』『ポ』などの濁点、半濁点がもれてしまうのですが
カとホの中に入れればよいわけですよね。まだ、他に条件が加わるのでしょうか？

Sub ShiftLineItmes()
　'振り分けマクロ

If c.Value <> "" Then
　　　　sTxt = c.Phonetic.Text
　　　　sTxt = Left(StrConv(sTxt, vbNarrow + vbKatakana), 1)　'←ここに一行加えます。☆
　　　　sTxt = Trim(Left(StrConv(sTxt, vbWide + vbHiragana), 1))

直接、質問には関係ない事なのですが、個人用マクロブックの標準モジュールに以下のマクロを貼り付けて、シートのタブを、クイックツールバーで呼び出しています。いくらシートの数が多くても大丈夫です。今回のケースにはピッタリのマクロです。このマクロの置く所は、クイックツールバー以外にはなさそうです。

Public Sub SheetListOpen()
　Application.CommandBars("Workbook tabs").ShowPopup
End Sub

なお、
If sTxt Like "*[Ａ-Ｚ]*" Then sTxt = StrConv("A-Z", vbWide)
は、シートA-Zが、'A'なら、以上の右辺を'A' と換えて良さそうだと思うでしょうけれども、全体を直さないとうまく行かないはずです。
シート名は、問題発生を避けるために、わざと、全角文字で出来上っています。

30246kiku · Answer

＃１１です複数列一気になら、雰囲気 Samp3 でどうなりますか Public Sub Samp3() 　　Dim ws As Worksheet 　　Dim dic As Object, dicS As Object 　　Dim vW As Variant, v As Variant 　　Dim sS As String 　　Dim i As Long 　　Const CERRCHR As String = "★" 　　Set dic = CreateObject("Scripting.Dictionary") 　　Set dicS = CreateObject("Scripting.Dictionary") 　　Application.ScreenUpdating = False 　　With Worksheets("入力用") 　　　　For Each ws In Worksheets 　　　　　　If (ws.Name <> .Name) Then 　　　　　　　　dic.Add ws.Name, ws 　　　　　　　　ws.Cells.Clear 　　　　　　End If 　　　　Next 　　　　With .Range("B5", .Cells(Rows.Count, "B").End(xlUp)) 　　　　　　ReDim vW(1 To .Rows.Count, 1 To 1) 　　　　　　For i = 1 To .Rows.Count 　　　　　　　　sS = GetPho(.Cells(i).Value) 　　　　　　　　If (Len(sS) > 0) Then 　　　　　　　　　　If (Not dic.Exists(sS)) Then 　　　　　　　　　　　　Set ws = Worksheets.Add _ 　　　　　　　　　　　　　　　　(After:=Worksheets(Worksheets.Count)) 　　　　　　　　　　　　ws.Name = sS 　　　　　　　　　　　　dic.Add sS, ws 　　　　　　　　　　End If 　　　　　　　　　　If (Not dicS.Exists(sS)) Then 　　　　　　　　　　　　Set dicS(sS) = .Cells(1).Offset(-1) 　　　　　　　　　　End If 　　　　　　　　　　Set dicS(sS) = Union(dicS(sS), .Cells(i)) 　　　　　　　　Else 　　　　　　　　　　vW(i, 1) = CERRCHR 　　　　　　　　End If 　　　　　　Next 　　　　　　.Offset(, -1).Value = vW 　　　　End With 　　　　.Activate 　　End With 　　For Each vW In dicS.Keys 　　　　With dic(vW) 　　　　　　dicS(vW).EntireRow.Copy .Cells(4, "A") 　　　　　　.Columns.AutoFit 　　　　End With 　　Next '　　For Each v In dic.Keys ' データのないシート削除 '　　　　If (Not dicS.Exists(v)) Then '　　　　　　Application.DisplayAlerts = False '　　　　　　dic(v).Delete '　　　　　　Application.DisplayAlerts = True '　　　　End If '　　Next 　　Application.ScreenUpdating = True 　　Set dic = Nothing 　　Set dicS = Nothing End Sub Private Function GetPho(vSrc As Variant) As String 　　Dim sS As String 　　Const COUTCHR As String = "!#$%&'(*/<>[{" 　　If (Len(vSrc) = 0) Then Exit Function 　　sS = Application.GetPhonetic(vSrc) 　　If (Len(sS) = 0) Then Exit Function 　　sS = Left(StrConv(Left(sS, 1), vbKatakana + vbNarrow + vbUpperCase), 1) 　　If (sS Like "[A-Z]") Then 　　　　sS = "A-Z" 　　ElseIf (InStr(COUTCHR, sS) > 0) Then 　　　　sS = "" 　　Else 　　　　sS = StrConv(sS, vbHiragana + vbWide) 　　End If 　　GetPho = sS End Function

soixante · Answer

再び#1です。

すみません、回答ではないのですが、慌てて参りました（笑。
いえいえ、ヘッポコ云々は冗談のつもりで書いたのですが、エラく変な空気を作ってしまいましたね、申し訳ありません。
字面だけですと難しいですね〜（汗。

わたしもまだまだ精進せねばなあと常日頃から考えておりますが、WindFaller様のコードはいつも勉強になっています。
ああこんな方法があるんだ、とか、こんなステートメントあるのね、とか、学びの連続です。
いつもありがとうございます。
今回もちょっと最終形を教材にさせて頂こうと思っております。
良いものが出来上がるのを祈っております。

ホントすみませんm(_ _;)m 汗。

30246kiku · Answer

＃１０ですデータ量が大量なら、以下の Samp2 の方が速くなるかも Samp1 からの変更点は、シートへの書き出し回数を減らす・初めは、どのシートにどの行を書き出すかを単に覚え・各シートへ書き出す行/行数が求まったら・その行数分の配列を用意して、配列の内容を作って・１シート１回の書き出しで Public Sub Samp2() 　　Dim ws As Worksheet 　　Dim dic As Object, dicS As Object 　　Dim vA As Variant, v As Variant 　　Dim vB As Variant, vW As Variant 　　Dim sS As String 　　Dim i As Long, j As Long 　　Const CERRCHR As String = "★" 　　Set dic = CreateObject("Scripting.Dictionary") 　　Set dicS = CreateObject("Scripting.Dictionary") 　　Application.ScreenUpdating = False 　　With Worksheets("入力用") 　　　　For Each ws In Worksheets 　　　　　　If (ws.Name <> .Name) Then 　　　　　　　　dic.Add ws.Name, ws 　　　　　　　　ws.Cells.Clear 　　　　　　End If 　　　　Next 　　　　With .Range("B4", .Cells(Rows.Count, "B").End(xlUp)) 　　　　　　vA = .Resize(, 3) 　　　　　　ReDim vW(1 To UBound(vA), 1 To 1) 　　　　　　For i = 2 To UBound(vA) 　　　　　　　　sS = GetPho(vA(i, 1)) 　　　　　　　　If (Len(sS) > 0) Then 　　　　　　　　　　If (Not dic.Exists(sS)) Then 　　　　　　　　　　　　Set ws = Worksheets.Add _ 　　　　　　　　　　　　　　　　(After:=Worksheets(Worksheets.Count)) 　　　　　　　　　　　　ws.Name = sS 　　　　　　　　　　　　dic.Add sS, ws 　　　　　　　　　　End If 　　　　　　　　　　If (Not dicS.Exists(sS)) Then 　　　　　　　　　　　　dicS.Add sS, CreateObject("Scripting.Dictionary") 　　　　　　　　　　　　dicS(sS)(1) = Empty 　　　　　　　　　　End If 　　　　　　　　　　dicS(sS)(i) = Empty 　　　　　　　　Else 　　　　　　　　　　vW(i, 1) = CERRCHR 　　　　　　　　End If 　　　　　　Next 　　　　　　vW(1, 1) = "結果" 　　　　　　.Offset(, -1).Value = vW 　　　　End With 　　　　.Activate 　　End With 　　For Each vW In dicS.Keys 　　　　ReDim vB(1 To dicS(vW).Count, 1 To 3) 　　　　i = 1 　　　　For Each v In dicS(vW).Keys 　　　　　　For j = 1 To 3 　　　　　　　　vB(i, j) = vA(v, j) 　　　　　　Next 　　　　　　i = i + 1 　　　　Next 　　　　With dic(vW) 　　　　　　.Cells(1, "A").Resize(UBound(vB), 3).Value = vB 　　　　　　.Rows(1).HorizontalAlignment = xlCenter 　　　　　　.Columns.AutoFit 　　　　End With 　　Next '　　For Each v In dic.Keys ' データのないシート削除 '　　　　If (Not dicS.Exists(v)) Then '　　　　　　Application.DisplayAlerts = False '　　　　　　dic(v).Delete '　　　　　　Application.DisplayAlerts = True '　　　　End If '　　Next 　　Application.ScreenUpdating = True 　　Set dic = Nothing 　　Set dicS = Nothing End Sub Private Function GetPho(vSrc As Variant) As String 　　Dim sS As String 　　Const COUTCHR As String = "!#$%&'(*/<>[{" 　　If (Len(vSrc) = 0) Then Exit Function 　　sS = Application.GetPhonetic(vSrc) 　　If (Len(sS) = 0) Then Exit Function 　　sS = Left(StrConv(Left(sS, 1), vbKatakana + vbNarrow + vbUpperCase), 1) 　　If (sS Like "[A-Z]") Then 　　　　sS = "A-Z" 　　ElseIf (InStr(COUTCHR, sS) > 0) Then 　　　　sS = "" 　　Else 　　　　sS = StrConv(sS, vbHiragana + vbWide) 　　End If 　　GetPho = sS End Function

30246kiku · Answer

解決されてましたらスルーしてください一気に処理してみました概要として・シート "入力用" 以外のシート全て内容をクリアして・"入力用" のデータ B4 ～ B 最終行で３列分を vA に読み込んでおいて・品名部分の文字列から、コピー先シート名を求め・そのシートが無ければ、シートを作成して・初めてコピーする時には、項目行を作って・内容を設定してこの時、シート名を求め切れなければ A 列に ★ マークを付けようかな後半で、入力用以外のシートを再度なめて・A1 が埋まっていれば、列幅の自動調整・埋まってなければ、シートを削除（現在コメントに） ※ シートが無ければシートを作成していきますが、並びは不問事前に作ってあって、シート削除することが無ければ並びは変わりません極端なことを言えば、入力用シートのみの状態で Samp1 を実行すると必要なシートのみが並び順不問（品名での出現順）で作成されていきますなお、シート名は半角　"A-Z" 、全角 "あ" ～になります ※ >　　Const COUTCHR As String = "!#$%&'(*/<>[{" 品名が上記で始まっていた場合コピーはせず、A 列に ★ 他の記号もあるのなら編集をまた >　　ElseIf (InStr(COUTCHR, sS) > 0) Then >　　　　sS = "" 部分で、別のシート名を設定するとか ※ 品名の読みは Application.GetPhonetic で求めているだけなので実際の読みと異なるものがあると思いますが Public Sub Samp1() 　　Dim ws As Worksheet 　　Dim dic As Object, dicS As Object 　　Dim vA As Variant, v As Variant 　　Dim sS As String 　　Dim i As Long, j As Long 　　Const CERRCHR As String = "★" 　　Set dic = CreateObject("Scripting.Dictionary") 　　Set dicS = CreateObject("Scripting.Dictionary") 　　Application.ScreenUpdating = False 　　With Worksheets("入力用") 　　　　For Each ws In Worksheets 　　　　　　If (ws.Name <> .Name) Then 　　　　　　　　dic.Add ws.Name, ws 　　　　　　　　ws.Cells.Clear 　　　　　　End If 　　　　Next 　　　　With .Range("B4", .Cells(Rows.Count, "B").End(xlUp)) 　　　　　　vA = .Resize(, 3) 　　　　　　For i = 2 To UBound(vA) 　　　　　　　　sS = GetPho(vA(i, 1)) 　　　　　　　　If (Len(sS) > 0) Then 　　　　　　　　　　If (Not dic.Exists(sS)) Then 　　　　　　　　　　　　Set ws = Worksheets.Add _ 　　　　　　　　　　　　　　　　(After:=Worksheets(Worksheets.Count)) 　　　　　　　　　　　　ws.Name = sS 　　　　　　　　　　　　dic.Add sS, ws 　　　　　　　　　　End If 　　　　　　　　　　With dic(sS) 　　　　　　　　　　　　If (Not dicS.Exists(sS)) Then 　　　　　　　　　　　　　　.Cells(1, "A").Resize(, 3).Value = _ 　　　　　　　　　　　　　　　　Array(vA(1, 1), vA(1, 2), vA(1, 3)) 　　　　　　　　　　　　　　dicS(sS) = Empty 　　　　　　　　　　　　End If 　　　　　　　　　　　　With .Cells(.Rows.Count, "A").End(xlUp).Offset(1) 　　　　　　　　　　　　　　.Resize(, 3).Value = _ 　　　　　　　　　　　　　　　　Array(vA(i, 1), vA(i, 2), vA(i, 3)) 　　　　　　　　　　　　End With 　　　　　　　　　　End With 　　　　　　　　　　vA(i, 1) = Empty 　　　　　　　　Else 　　　　　　　　　　vA(i, 1) = CERRCHR 　　　　　　　　End If 　　　　　　Next 　　　　　　vA(1, 1) = "結果" 　　　　　　.Offset(, -1).Value = vA 　　　　End With 　　　　.Activate 　　End With 　　For Each v In dic.Items 　　　　With v 　　　　　　If (.Cells(1, "A") <> "") Then 　　　　　　　　.Columns.AutoFit 　　　　　　Else ' データのないシート削除 '　　　　　　　　Application.DisplayAlerts = False '　　　　　　　　.Delete '　　　　　　　　Application.DisplayAlerts = True 　　　　　　End If 　　　　End With 　　Next 　　Application.ScreenUpdating = True 　　Set dic = Nothing 　　Set dicS = Nothing End Sub Private Function GetPho(vSrc As Variant) As String 　　Dim sS As String 　　Const COUTCHR As String = "!#$%&'(*/<>[{" 　　If (Len(vSrc) = 0) Then Exit Function 　　sS = Application.GetPhonetic(vSrc) 　　If (Len(sS) = 0) Then Exit Function 　　sS = Left(StrConv(Left(sS, 1), vbKatakana + vbNarrow + vbUpperCase), 1) 　　If (sS Like "[A-Z]") Then 　　　　sS = "A-Z" 　　ElseIf (InStr(COUTCHR, sS) > 0) Then 　　　　sS = "" 　　Else 　　　　sS = StrConv(sS, vbHiragana + vbWide) 　　End If 　　GetPho = sS End Function

WindFaller · Answer

soixante 様へ

>わたしのヘッポコ回答は破棄頂き、

後出しで気にはしていたのですが、そんなことはおっしゃらないでください。それに、そのような気持ちにさせたことを申し訳なく思っています。

私は、今、自分自身との戦いのようなもので、ある病で、最近は、夜はずっと、意識が飛び飛びです。それでも、VBAは、信じられないと思いますが、無意識に近いままで一気に書いています。いわば、過去の自分が書かせているようなものです。それでも、過去の自分(別のハンドル)には及びません。このように掲示板で書いていることが、病の進行を抑えているようなものなのです。多少の焦りと不安が、掲示板に向かわせています。

そんなわけで、よかったら、気を取り直して、一緒に書いていただけたら、と思います。

soixante · Answer

#1です。

#6,7 でご回答されているWindFaller様のコードは、データ更新時やエラー対応など、トータル的に考慮して設計されたものですので、わたくしも勉強させて頂きます。

つきましては、わたしのヘッポコ回答は破棄頂き、完成に向けてご対応下さると幸いですm(_ _)m

WindFaller · Answer

こんばんは。後出しで、すみません。何か修正事項が生まれるたびに遅くなってきてしまいました。 >作成するシートは、 > 『アルファベットのみ』1枚と、『あ～も』の35枚、『や・ゆ・よ』 > 『ら～ろ』、『わ』の9枚で全部で45枚です今、アップロードしようとしたら、そうなっていたので、急遽書き換えました。最初、アルファベットもそれぞれ入れたので、70枚になってしまいました。 45枚に切り替えました。アルファベット用のシート名は、A-Z（全角)にしています。私の場合は、新しいブックの方が楽かもしれませんが、まだ、補足部分など、細かい所は読み落としているかもしれません。マクロを書き始めた時点では、件数は0でした。既存のブックに行う場合は、一度、CheckSheetsName　という名前のマクロを実行してください。ただし、不明なシート名は、エラーとしてイミディエイトウィンドウに吐き出されます。これを手直ししていたら、時間が掛かってしまいました。まだ、これは不十分です。 >不明な点などありましたらご指摘ください。不明なというよりも、少し、難しい部分があると思います。いくつかのチェックポイントがあって、問題があると、全部消さなくてはならなくなります。思ったよりもややこしいと思います。 >商品の追加は不定期で、マクロをかけるタイミングもまちまちですので上書きといっても、前にあったものを削除するか、追加するかどちらかになってしまいます。マクロの簡単な説明と内訳 ------- MakeOrderSheets 　シートの一覧作成。ただし、アルファベットも全角です。　手動でシートを作っている場合は振り分けはうまく行かない可能性があります。 CheckListString 　重要：振り分け前に、読みが取れるかチェックしなければならないが、取れない場合は、読みをマクロ関数で読みがなを起こします。 ShiftLineItmes 　振り分けします。エラーが発生している時には、イミディエイトウィンドウの中に書き出します。 '------- おまけ ClearSheets 　今回は、上書き方式ではありませんから、不要な場合は、シート内の転記されたデータは消去する。 CheckSheetsName() 　シート名をチェックするマクロ　現行では、弾き出す名前に、英語名などがあると、失敗します。なお、こちらに思い違いがあった場合には、深追いはしません。 '// Sub MakeOrderSheets() 'シートを揃える Dim Acsh As Worksheet Dim Ar As Variant Dim i As Long Dim ArTitle: ArTitle = Split("品　名,型式,値段", ",") Const CHRLIST As String = _ "A-Z,あ,い,う,え,お,か,き,く,け,こ," & _ "さ,し,す,せ,そ,た,ち,つ,て,と," & _ "な,に,ぬ,ね,の,は,ひ,ふ,へ,ほ," & _ "ま,み,む,め,も,や,ゆ,よ,わ,ら," & _ "り,る,れ,ろ" Set Acsh = ActiveSheet Ar = Split(CHRLIST, ",") Application.ScreenUpdating = False For i = LBound(Ar) To UBound(Ar) 　With Worksheets.Add(After:=Worksheets(Worksheets.Count)) 　 .Name = Trim(StrConv(Ar(i), vbWide)) 　 .Range("A1").Resize(, 3).Value = ArTitle 　 .Range("A1").Resize(, 3).HorizontalAlignment = xlCenter 　End With Next i Application.ScreenUpdating = True Acsh.Activate End Sub Sub CheckListString() 　'振り分けマクロの前に必ず実行する、よみがなの確保　Dim c As Range 　For Each c In Range("B5", Cells(Rows.Count, 2).End(xlUp)) 　　If c.Value <> "" Then 　　　　If c.Phonetic.Text Like "*[一-龠]*" Then 　　　　　c.SetPhonetic 　　　　End If 　　End If 　Next c End Sub '/// Sub ShiftLineItmes() 　'振り分けマクロ　'最初の文字の読みもしくは文字によって、振り分ける　Dim c As Range 　Dim sTxt As String 　Dim errflg As Boolean 　On Error Resume Next 　Application.ScreenUpdating = False 　For Each c In Range("B5", Cells(Rows.Count, 2).End(xlUp)) 　　 If c.Value <> "" Then 　　　　sTxt = c.Phonetic.Text 　　　　sTxt = Trim(Left(StrConv(sTxt, vbWide + vbHiragana), 1)) 　　　　If sTxt Like "*[Ａ-Ｚ]*" Then sTxt = StrConv("A-Z", vbWide) 　　　　With Worksheets(sTxt) 　　　　　'A列の2行目から、または最後尾から　　　　　.Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(, 3).Value = c.Resize(, 3).Value 　　　　　If Err() <> 0 Then 　　　　　　Debug.Print "シート:" & sTxt; ; c.Value 　　　　　　Err.Clear 　　　　　　errflg = True 　　　　　End If 　　　　End With 　　　End If 　Next c 　Application.ScreenUpdating = True 　If errflg Then 　　 MsgBox "エラーが発生しているので、イミディエイトウィンドウで、記録と照らしあわせてください。", vbExclamation 　End If 　On Error GoTo 0 　Beep End Sub '-------終わり----- '-----おまけ----- Sub ClearSheets() '今回のマクロは、積み重ね式で記帳されるので、消す場合もマクロで消す Dim Acsh As Worksheet Dim Ar As Variant Dim i As Long Dim LastRow As Long Const CHRLIST As String = _ "A-Z,あ,い,う,え,お,か,き,く,け,こ," & _ "さ,し,す,せ,そ,た,ち,つ,て,と," & _ "な,に,ぬ,ね,の,は,ひ,ふ,へ,ほ," & _ "ま,み,む,め,も,や,ゆ,よ,わ,ら," & _ "り,る,れ,ろ" Set Acsh = ActiveSheet Ar = Split(CHRLIST, ",") Application.ScreenUpdating = False For i = LBound(Ar) To UBound(Ar) 　 With Worksheets(Trim(StrConv(Ar(i), vbWide))) 　　LastRow = .Cells(Rows.Count, 1).End(xlUp).Row 　　If LastRow > 1 Then 　　　.Range("A2", .Cells(LastRow, 3)).ClearContents 　　End If 　 End With Next i Acsh.Activate End Sub Sub CheckSheetsName() 'シート名をチェックするマクロ(未完成です) Dim sh As Worksheet Dim flg As Boolean For Each sh In Worksheets 　If Trim(sh.Name) Like "[あ-ん]" Then 　 If Len(sh.Name) > 1 Then 　　 sh.Name = Trim(sh.Name) 　 End If 　ElseIf StrConv(sh.Name, vbUpperCase + vbNarrow) Like "A*" Then 　　 sh.Name = StrConv("A-Z", vbWide) 　ElseIf Not sh.Name Like "Sheet*" Then 　　flg = True 　　Debug.Print sh.Name 　End If Next sh 　If flg Then 　 MsgBox "不明なシートがあります。イミディエイトウィンドウを見てください!", vbExclamation 　End If End Sub

soixante · Answer

すみません、D列は価格でしたね。さっきのヘッダー作成マクロは適宜変更して下さい。
left関数の列さえ残ってればOKです。

で、いよいよ振り分け。
'----------------------------------------------------------------------
Sub d_振り分け()

Dim Ws1 As Worksheet, r As Long
Dim p As Long, q As Long
Dim Furig As String, Rng As Range
Dim LstRow As Long, TgtSht As Integer

Set Ws1 = Worksheets("入力用")

r = 4     '4行目からループ
Do While Ws1.Cells(r, 2).Value <> ""  '入力用シートのB列が空欄でない間はループ
    Furig = Ws1.Cells(r, 5).Value      'Furig に、E列の値（頭文字）を入れる
    
    If Furig Like "[ア-ン]" Then    'Furig がカタカナだったら
        p = 2
        Do Until Worksheets(p).Name = Furig  'シート名がその頭文字になるまでループ
            p = p + 1
        Loop
        TgtSht = p    '該当したシート番号をTgtshtに
    Else              'Furigがカタカナでないなら
        TgtSht = 2    'Tgtshtは２
    End If
    
    With Ws1    'コピー元の範囲選択
        Set Rng = .Range(.Cells(r, 2), .Cells(r, 5))
    End With
    Rng.Copy  'コピー
    LstRow = Worksheets(TgtSht).Cells(Rows.Count, 2).End(xlUp).Row + 1  'コピー先シートの最終行取得
    Worksheets(TgtSht).Cells(LstRow, 2).PasteSpecial Paste:=xlPasteAll  '貼る
    r = r + 1
Loop
Application.CutCopyMode = False

For q = 2 To Worksheets.Count
    Worksheets(q).Select
    Cells(2, 2).Select
Next q

Ws1.Select

MsgBox "End."
End Sub
'-------------------------------------------------------------------------------

soixante · Answer

補足２の画面では、C列が型番ではなくなってしまいましたが、当初の例示通り、以下のイメージで書きました。
・B列　品名
・C列　型番
・D列　振り仮名列　（phonetic関数）
・E列　振り仮名の左一文字（left関数）
・シートは一番左が「入力用」、それ以降右に、「A」「ア」「イ」・・・・

まず、2枚目以降のシートに、入力用シートと同じヘッダーを振ります。
'-------------------------------------------------------------------
Sub c_ヘッダー作成()
Dim k As Integer, Rng As Range
Dim Ws1 As Worksheet
Set Ws1 = Worksheets("入力用")

Application.ScreenUpdating = False
For k = 2 To Worksheets.Count
    With Ws1
        Set Rng = .Range(.Cells(2, 2), .Cells(2, 5))
    End With
    Rng.Copy
    With Worksheets(k).Cells(2, 2)
        .PasteSpecial Paste:=xlPasteAll
        .PasteSpecial Paste:=xlPasteColumnWidths
    End With
Next k

Application.CutCopyMode = False
Application.ScreenUpdating = True
MsgBox "End."

End Sub
’----------------------------------------------------------------

【マクロ】あいうえお順のシートに振分けしたい

#6の回答者です。

＃１１です

再び#1です。

＃１０です

解決されてましたらスルーしてください

soixante 様へ

#1です。

こんばんは。

すみません、D列は価格でしたね。

補足２の画面では、C列が型番ではなくなってしまいましたが、当初の例示通り、以下のイメージで書きました。

似たような質問が見つかりました

このQ&Aを見た人はこんなQ&Aも見ています

関連するカテゴリからQ&Aを探す

このQ&Aを見た人がよく見るQ&A

デイリーランキングこのカテゴリの人気デイリーQ&Aランキング

マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング