エクセルのマクロで条件一致のデータを別シート（複数）に転記したい

Question

変動するセル範囲からB列を基準にしてソートし、別シートに転記したいのですが、うまくいきません。
商品名が多数あり変動するために通常のオートフィルター等では無く、マクロを活用して別シートに転記する方法で教えてください。

以下の2つのコードを組み合わせて、複数の商品別シートを作成したいのです。
大変恐縮ですが、詳しい方、マクロのコードを教えてください。

Sub 分類区切線()
    Dim i As Integer
    Dim 最終行 As Long
    最終行 = Range("A5").CurrentRegion.Rows.Count + 5
    For i = 6 To 最終行
        If Range("B" & i).Value <> Range("B" & i - 1).Value Then
            Range("B" & i - 1).Resize(1, 6).Copy
            Worksheets.Add
            Range("A1").PasteSpecial
            
        End If
    Next
End Sub

Sub 別シート作成()
'
' 別シートにヘッドをコピー
'

    Sheets.Add After:=Sheets(Sheets.Count)
    Sheets("商品").Select
    Rows("5:5").Select
    Selection.Copy
    Sheets(Sheets.Count).Select
    Selection.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    ActiveSheet.Paste
    Application.CutCopyMode = False
End Sub

30246kiku · Accepted Answer

＃１２です

CurrentRegion　で求めた範囲が、イメージした通りじゃないみたい
以下、★ 部分変更したので、どうなりますか

Public Sub Samp2()
　　Dim rng As Range
　　Dim vA As Variant, vW As Variant
　　Dim i As Long, j As Long, k As Long, n As Long

Set rng = Worksheets(Worksheets.Count).Range("A1")

Application.ScreenUpdating = False
　　With Worksheets("商品")
　　　　With .Range("A5") ' ★
　　　　　　With Range(.End(xlDown), .End(xlToRight)) ' ★
　　　　　　　　n = .Columns.Count
　　　　　　　　ReDim vW(1 To n)
　　　　　　　　For k = 1 To n
　　　　　　　　　　vW(k) = .Cells(1, k).ColumnWidth
　　　　　　　　Next
　　　　　　　　With .Resize(, n + 1)
　　　　　　　　　　With .Columns(n + 1)
　　　　　　　　　　　　.Formula = "=ROW()"
　　　　　　　　　　　　.Value = .Value
　　　　　　　　　　End With
　　　　　　　　　　.Sort .Cells(2), xlAscending, Header:=xlYes
　　　　　　　　End With
　　　　　　　　vA = .Columns(2).Resize(, 2).Value

i = 2
　　　　　　　　While (i <= UBound(vA))
　　　　　　　　　　For j = i + 1 To UBound(vA)
　　　　　　　　　　　　If (vA(i, 1) <> vA(j, 1)) Then Exit For
　　　　　　　　　　Next
　　　　　　　　　　With Worksheets.Add(After:=rng.Worksheet)
　　　　　　　　　　　　For k = 1 To n
　　　　　　　　　　　　　　.Cells(1, k).ColumnWidth = vW(k)
　　　　　　　　　　　　Next
　　　　　　　　　　　　Set rng = .Range("A1")
　　　　　　　　　　　　On Error Resume Next
　　　　　　　　　　　　.Name = vA(i, 2)
　　　　　　　　　　　　On Error GoTo 0
　　　　　　　　　　End With
　　　　　　　　　　Union(.Rows(1), .Rows(i).Resize(j - i)).Copy rng
　　　　　　　　　　i = j
　　　　　　　　Wend

With .Resize(, n + 1)
　　　　　　　　　　.Sort .Cells(n + 1), xlAscending, Header:=xlYes
　　　　　　　　　　.Columns(n + 1).ClearContents
　　　　　　　　End With
　　　　　　End With ' ★
　　　　End With
　　　　.Activate
　　End With
　　Application.ScreenUpdating = True
End Sub

めぐみん_ · Answer

No.16です。

仮にNo.15の予想が外れているようであれば、初級レベルでは難しそうなのでベテラン回答者さんにお任せです。
十数年やっても初級レベルから脱せないのは情けないですよね・・・
いつになったら『参考程度に』のスタンプを自信をもって使えるのだろう。。。多分その日は来ないかな？

めぐみん_ · Answer

商品がNullとなっていると言う事は、商品の列の行数より多い列が存在しているのかな？
例えばＩＤや日付が事前に多く入力されているとか、数式を余分に書いている列が存在するなど。

それならデータのある行が存在する代わりに、商品が空白になっててもおかしくはないかも。

めぐみん_ · Answer

No.11です。

環境の違いでしょうかね？
私は５万行を指定しておいて実際は２０行足らずでも空白（Null）は拾ってないのですが。。。。
別の質問者さんに回答した時も今回のような問題は聞いてませんし。

No.12さんのコードが本来のExcelにある純粋な機能で作業されているので、そちらの方が宜しいのかも知れません。
ただ画像では４行目にデータが存在していないけど、実際には何かあるって事で起きているトラブルみたいに思えます。
.CurrentRegion を使う上での注意すべき点ではありますので、その辺を補足されては？
私は老眼なので最初に『１～４行目』を気にしましたから同じようにするなら Intersect を使用してます。
老眼が良いのか悪いのか・・・

30246kiku · Answer

標準モジュールに記述し、Samp1 を実行してみます
処理対象は、商品　シート

どうなりますか

Option Explicit

Public Sub Samp1()
　　Dim rng As Range
　　Dim vA As Variant, vW As Variant
　　Dim i As Long, j As Long, k As Long, n As Long

Set rng = Worksheets(Worksheets.Count).Range("A1")

Application.ScreenUpdating = False
　　With Worksheets("商品")
　　　　With .Range("A5").CurrentRegion
　　　　　　n = .Columns.Count
　　　　　　ReDim vW(1 To n)
　　　　　　For k = 1 To n
　　　　　　　　vW(k) = .Cells(1, k).ColumnWidth
　　　　　　Next
　　　　　　With .Resize(, n + 1)
　　　　　　　　With .Columns(n + 1)
　　　　　　　　　　.Formula = "=ROW()"
　　　　　　　　　　.Value = .Value
　　　　　　　　End With
　　　　　　　　.Sort .Cells(2), xlAscending, Header:=xlYes
　　　　　　End With
　　　　　　vA = .Columns(2).Resize(, 2).Value

i = 2
　　　　　　While (i <= UBound(vA))
　　　　　　　　For j = i + 1 To UBound(vA)
　　　　　　　　　　If (vA(i, 1) <> vA(j, 1)) Then Exit For
　　　　　　　　Next
　　　　　　　　With Worksheets.Add(After:=rng.Worksheet)
　　　　　　　　　　For k = 1 To n
　　　　　　　　　　　　.Cells(1, k).ColumnWidth = vW(k)
　　　　　　　　　　Next
　　　　　　　　　　Set rng = .Range("A1")
　　　　　　　　　　On Error Resume Next
　　　　　　　　　　.Name = vA(i, 2)
　　　　　　　　　　On Error GoTo 0
　　　　　　　　End With
　　　　　　　　Union(.Rows(1), .Rows(i).Resize(j - i)).Copy rng
　　　　　　　　i = j
　　　　　　Wend

With .Resize(, n + 1)
　　　　　　　　.Sort .Cells(n + 1), xlAscending, Header:=xlYes
　　　　　　　　.Columns(n + 1).ClearContents
　　　　　　End With
　　　　End With
　　　　.Activate
　　End With
　　Application.ScreenUpdating = True
End Sub

めぐみん_ · Answer

＞.Name = objRS1.Fields("F3").Value　　ここでデバックとなります。

エラーになりうる原因として調べるには、

この行の前に
Debug.Print objRS1.Fields("F3").Value 'イミディエイトウィンドウに表示が出るかどうか
.Name = objRS1.Fields("F3").Value '　　ここでデバックとなります。
このようにイミディエイトウィンドウに値の表示が出るかどうか。
すなわち商品名に空白が紛れているかを調べるのと、『商品名』は仮の項目で実際は半角文字を使った物でその値がシート名に使えない記号を用いている場合。

位しか思いつかないですね。

めぐみん_ · Answer

仮にコードが複数で商品名が１つの関係だったとして、商品名でシート訳をしたい（シート名が商品名）と言うのであれば多少改造は必要ですが不可能ではないですよ。
１日ちょいあれば可能かと。（改造と検証で）

めぐみん_ · Answer

ダブってしまっているんですね。
追加するのは１行だけだったのですが、わかりやすいようにと思い前後を載せた（言葉が足りなかった）ミスなのかな？

With WS
.Name = objRS1.Fields("F3").Value
r1.EntireRow.Copy .Range("A5")
.Range("A6").CopyFromRecordset objRS2
With .Range("A5").CurrentRegion.Borders
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
End With
' With WS
' .Name = objRS1.Fields("F3").Value
' r1.EntireRow.Copy .Range("A5")
' .Range("A6").CopyFromRecordset objRS2
' .Range("A6", .Cells(Rows.Count, "A").End(xlUp)).NumberFormat = "m月d日" '★　追加
' With .Range("A5").CurrentRegion.Borders
objRS2.Close
objRS1.MoveNext
Loop

は

With WS
.Name = objRS1.Fields("F3").Value '★←　ここは F2 の方が良いのかな？コードは違うけど商品名が同じ場合はシート名はコードにしないとならないので
r1.EntireRow.Copy .Range("A5")
.Range("A6").CopyFromRecordset objRS2
.Range("A6", .Cells(Rows.Count, "A").End(xlUp)).NumberFormat = "m月d日" '★←　ここだけ追加と書けば良かったのかも
With .Range("A5").CurrentRegion.Borders
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
End With

objRS2.Close
objRS1.MoveNext
Loop

ですね。
実際はWithに対するEnd Withがないのが原因だったのでしょう。

めぐみん_ · Answer

実際今のコードを全て提示できますでしょうか？
補足を使うと多分２回くらいにはわかれるかもですけど。

めぐみん_ · Answer

No.6のお礼について。

そのエラーメッセージについてはこちらでは発生してませんでしたね。

シート名：商品　はあってますよね？
あとエラーメッセージが出てシートは１つも作成されないのでしょうか？
データ行数は５万行超えてますか？（念の為）

エクセルのマクロで条件一致のデータを別シート（複数）に転記したい

＃１２です

No.16です。

商品がNullとなっていると言う事は、商品の列の行数より多い列が存在しているのかな？

No.11です。

標準モジュールに記述し、Samp1 を実行してみます

＞.Name = objRS1.Fields("F3").Value ここでデバックとなります。

仮にコードが複数で商品名が１つの関係だったとして、商品名でシート訳をしたい（シート名が商品名）と言うのであれば多少改造は必要ですが不可能ではないですよ。

ダブってしまっているんですね。

実際今のコードを全て提示できますでしょうか？

No.6のお礼について。

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

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

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

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

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

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

＞.Name = objRS1.Fields("F3").Value　　ここでデバックとなります。