人に聞けない痔の悩み、これでスッキリ >>

変動するセル範囲から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

「エクセルのマクロで条件一致のデータを別シ」の質問画像

質問者からの補足コメント

  • HAPPY

    今回教えていただいたコードで思い通りの表が作成できました。

    大変助かりました。
    コードの意味合いが理解できていないので基本から勉強してスキルを少しでも上げたいと思います。

    今後も宜しくお願い致します。

    No.14の回答に寄せられた補足コメントです。 補足日時:2020/07/05 14:14

A 回答 (16件中1~10件)

#12です



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
この回答への補足あり
    • good
    • 0
この回答へのお礼

ご連絡ありがとうございます。
時間が取れませんでしたので本日の夜に検証してみます。

お礼日時:2020/07/01 05:28

No.16です。



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

めぐみん 様

何度も教えていただきありがとうございました。
No.15に記載していただいたような余分な列はありませんでした。
trim関数で検証する必要があるかもしれません(検証の方法がよくわかりません)が、見た目およびカーソルの位置が各セルで一番左で点滅していることから、文字が入力されていないようです。

こちらのデータ保存が不十分なため
お手数をお掛けし申し訳ございませんでした。

初心者のため、分からない点が多くて基本から勉強し、教えていただいたコードを intersect の使用方法を含め理解できるようにしたいと思います。

本当に助かりました。
また、わからない点がありましたらご教示ください。

お礼日時:2020/07/05 14:11

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


例えばIDや日付が事前に多く入力されているとか、数式を余分に書いている列が存在するなど。

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

No.11です。



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

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

何度も回答ありがとうございます。

質問投稿した際に元データをうまく保存できなかったために再度作成したのですが、その際に4行目に不要な文字がありました。
ご指摘の通りでしたので、その文字を削除して対象行を50000行に戻して確認したのですが同じ場所でデバックが出ました。

本日の夜に再度 intersect をどのように使用するかも含めて検証してみます。

お礼日時:2020/07/01 05:27

標準モジュールに記述し、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
    • good
    • 0
この回答へのお礼

別のコードもご検討いただきありがとうございます。

上記コードで作表はできました。
ただし、ヘッダーとなる5行目の代わりに4行目が各シートに転記されます。

お礼日時:2020/06/29 23:59

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



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

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

位しか思いつかないですね。
    • good
    • 0
この回答へのお礼

ご連絡ありがとうございます

Debug.Print objRS1.Fields("F3").Value でイミディエイトウィンドウにはNullと表示されます。
また、50000行までを作表可能としてコード作成してもらっていますが、今回は、仮として86行目までのシートとしました。
そのため、50000の数値を86とした場合にはイミディエイトウインドウに該当商品名が表示されるとともに、商品名ごとのシートができました。

50000の個所が変数となりますのでどのようにしたらよろしいのでしょうか。

お礼日時:2020/06/29 23:52

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


1日ちょいあれば可能かと。(改造と検証で)
    • good
    • 0
この回答へのお礼

理解が低くて申し訳ありません。
やはり、1行目だけ追加しても
.Name = objRS1.Fields("F3").Value  ここでデバックとなります。


Set WS = Worksheets.Add(After:=Worksheets(Worksheets.Count))
With WS
.Name = objRS1.Fields("F3").Value  コードと商品名は1対なのでこのままでしょうか。
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
objRS1.Close
Set objRS1 = Nothing
Set objRS2 = Nothing
objCn.Close
Set r1 = Nothing
Set objCn = Nothing
End Sub

商品名でシート分けを行いたいと思います。

お礼日時:2020/06/28 22:46

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


追加するのは1行だけだったのですが、わかりやすいようにと思い前後を載せた(言葉が足りなかった)ミスなのかな?

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がないのが原因だったのでしょう。
    • good
    • 0

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


補足を使うと多分2回くらいにはわかれるかもですけど。
    • good
    • 0

No.6のお礼について。



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

シート名:商品 はあってますよね?
あとエラーメッセージが出てシートは1つも作成されないのでしょうか?
データ行数は5万行超えてますか?(念の為)
    • good
    • 0
この回答へのお礼

早速のご連絡ありがとうございます。
追加するように連絡いただいたコードを追記する前は、
.Name = objRS1.Fields("F3").Value
の場所でデバックとなります。(シートは追加されます。)

また、以下の場所に ’を外して 追記した場合は、LOOPの場所でエラーとなり、Doがありませんとの表示がされます。
(ただし、シートは追加されません。)
5万行をデータが越えることはありません。
シート名は商品です。
エラー解消する方法はありますでしょうか。

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

お礼日時:2020/06/28 21:33

お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!

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


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

人気Q&Aランキング