[[20170216155002]] 『グループ化と比較』(たいよう) ページの最後に飛ぶ

[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]

 

『グループ化と比較』(たいよう)

お世話になっております。

商品の内容を比較し、重複しないように1つのシートにまとめる、といったことをしたいと考えています。
マクロを作成したいのですが、実現方法が分からないので皆様のお力をお借りしたいと思います。

比較対象のシートの内容は下記のようになっています。

■シート1
品名  |部品 |数量
電話  |AAA|60
     |BBB|80

パソコン|BBB|70
     |CCC|20

電話  |AAA|60
     |BBB|10
     |CCC|50

■シート2
品名  |部品 |数量
パソコン|CCC|20
     |BBB|70

電話  |AAA|60
     |BBB|10

電話  |AAA|60
     |BBB|80

内容としては、
いくつかの商品が1つのシートに書かれており、それが複数シート集まったブックがある状態です。
列はどのシートも揃っているのですが、グループによって行数はバラバラです。
商品と商品の間は空白行が入っているもの、いないものも混在しています。

品名、部品、数量をまとめて1つのグループとして扱い、その他のグループと比較していくようになります。
品名、部品、数量、どれか一つが違うと違うグループとして扱いたいのですが、
品名が同じで部品・数量の順番が違うだけの場合は同じグループとして扱いたいと思っています。

そして、比較した結果として下記のようなシートを作成したいと考えています。

■重複なしシート
品名  |部品 |数量
電話  |AAA|60
     |BBB|80
電話  |AAA|60
     |BBB|10
     |CCC|50
電話  |AAA|60
     |BBB|10
パソコン|BBB|70
     |CCC|20

そもそも実現可能なのかというところもわからず苦戦しています。
実現できるかどうかの判断、または実現するためのコード、アドバイスなどをいただければと思います。
よろしくお願いします。

< 使用 Excel:Excel2016、使用 OS:Windows8 >


 >たいよう さん
 実現できますよ。まずは、アドバイスから

 例えば、
 **************************
  電話  |AAA|60 
     |BBB|10 
     |CCC|50
     |BBB|30
     |AAA|20
 **************************
 のグループなら、同じ行(ただし、2行目以降は、電話が入っているもの
 として取り扱う)の3つの文字列を「■」で結合して、
 電話■AAA■60
 電話■BBB■10
 電話■CCC■50
 電話■BBB■30
 電話■AAA■20
 の文字列を作成後、このグループだけで並び替える。すると、
 電話■AAA■20
 電話■AAA■60
 電話■BBB■10
 電話■BBB■30
 電話■CCC■50
 になる。上から順に、配列に格納してやる。
 このようにして、複数の配列ができる。
 完全一致する配列が存在したら、完全一致する2つめ以降の配列を無視する。
 -------------------------------------------------------------
 条件1:品名、部品、数量の文字列に「■」を使用していないこと
 条件2:品名、部品、数量の文字列の前後に、「半角スペース」
         の余計な文字列が付加していないこと(前後はダメだが、途中はよい!)
 (条件2は、コード上にて、Trim関数を使うと、文字列前後のスペースが取り除けます。)
 (条件1は、■を使用しているかどうか、事前チェックしてもいいです。)
 -------------------------------------------------------------
(マリオ) 2017/02/16(木) 17:29

 >たいよう さん
 ■質問です。
 >列はどのシートも揃っているのですが、グループによって行数はバラバラです。
 ・品名、部品、数量が記述されている列を具体的に教えて下さい。
 ・品名、部品、数量が入っている行は、何行目ですか?
 ・それぞれのシートで、最終行の判定は、部品が記述されている列で行うということで、いいですか?

 ***************************************************************************
 >それが複数シート集まったブックがある状態です。 
 エクセルファイルは、
「シート名:重複なしシート」と
「商品が記述された複数のシート(シート名は不明、または不定)」
 だけのシートで構成されていますか?

(マリオ) 2017/02/16(木) 17:37


 >マリオ様

回答ありがとうございます。
結合して、並べ替えを行って、配列で考えるのですね!
■は使用していないのでそのままで大丈夫そうです。
データの状態がまばらなのでTrimはかけた方がよさそうです…。

 >・品名、部品、数量が記述されている列を具体的に教えて下さい。
 >・品名、部品、数量が入っている行は、何行目ですか?
 >・それぞれのシートで、最終行の判定は、部品が記述されている列で行うということで、いいですか?

A1〜BI2 が見出しとなっており、
A3〜BI42 が商品の情報が記入されている範囲、
A43〜  メモ
となっています。
商品が書かれているシートは全てそのようになっているはずです。

A3〜BI42 のデータの範囲内で
「最終行の判定は、部品が記述されている列で行う」
という感じでしょうか。
(伝わりにくい表現ですみません…。)

ちなみに品目がA列、部品がD列、数量がG列、その他の列は備考のような情報が記載されています。
比較対象は品名、部品、数量の3つですが
転記の際はA列からBI列までをコピーできればと考えています。

 >エクセルファイルは、
 >「シート名:重複なしシート」と
 >「商品が記述された複数のシート(シート名は不明、または不定)」
 > だけのシートで構成されていますか?

不必要なシート1つ、
商品が記述された複数のシート(シート名は不定)、
不必要なシート6つ、の順となっています。

度々の質問になるのですが、同じブック内にシートを作成するのではなく、
新しいブックに「シート名:重複なしシート」を作る、ということも可能でしょうか?

(たいよう) 2017/02/16(木) 18:41


 >たいよう さん

 *************************************************************
 >不必要なシート1つ、 
 >商品が記述された複数のシート(シート名は不定)、 
 >不必要なシート6つ、の順となっています。 

 ということは、「不必要なシート1つ」、「不必要なシート6つ」
 の名前は固定ですね?
 仮に、この7つのシート名を
 「不1,不2,不3,不4,不5,不6,不7」とします。
 この7つ以外のシートを調べていけば、いいことになりますね。

 *************************************************************
 >新しいブックに「シート名:重複なしシート」を作る、
 >ということも可能でしょうか?

 可能です。ちなみに、
 「どの場所に保存したいか、ファイル名、シート名」の希望はありますか?
 ■どの場所(例えば、デスクトップまたは、マクロブックと同じフォルダ)
 ■ファイル名(まとめ_20170216.xlsx)
 ■シート名(シート名:一覧)

 *************************************************************
 元のエクセルファイルの拡張子を(xlsm)にしてもいいですか?
 マクロブックとして、module1に、コードを記述しようと思ってます。

(マリオ) 2017/02/16(木) 20:01


こんにちは

>ちなみに品目がA列、部品がD列、数量がG列、その他の列は備考のような情報が記載されています。
>比較対象は品名、部品、数量の3つですが
>転記の際はA列からBI列までをコピーできればと考えています。

大丈夫ですか?

比較対象は品名、部品、数量の3つが一致した場合の、A列〜BI列の内容は完全に一致するのですか?
品名、部品、数量の3つが一致しても、その他の列のデータが一致しない場合は、どの分のデータを
コピーするのですか?

(ウッシ) 2017/02/17(金) 07:52


 >たいよう さん

 次のような場合、重複なしシートは、どうなりますか?
 AAAは、グループ内で合算すると、数量はともに、60です!
 グループ内で、合算する処理を入れるか、
 グループ内で、部品が重複していたら、警告するか、
 どちらか、なのかな〜っと思ってますが…。
 **********************************
 ■シート1b
   品名  |部品 |数量 
   電話  |AAA|60 
      |BBB|10 
      |CCC|50 

 ■シート2b
   電話  |AAA|20 
      |BBB|10 
      |CCC|50 
      |AAA|40

(マリオ) 2017/02/17(金) 09:07


 >マリオ様

 >ということは、「不必要なシート1つ」、「不必要なシート6つ」の名前は固定ですね?
 >この7つ以外のシートを調べていけば、いいことになりますね。

はい、その通りです。
完全に不要のシートですのでそのシートに対しては何も行わない想定です。

 >「どの場所に保存したいか、ファイル名、シート名」の希望はありますか?
 >■どの場所(例えば、デスクトップまたは、マクロブックと同じフォルダ)
 >■ファイル名(まとめ_20170216.xlsx)
 >■シート名(シート名:一覧)

■場所   :デスクトップ
■ファイル名:商品一覧_20170216.xlsx ←日付は作成日
■シート名 :一覧
が希望です。

 >元のエクセルファイルの拡張子を(xlsm)にしてもいいですか?
 >マクロブックとして、module1に、コードを記述しようと思ってます。

はい、大丈夫です。

 >次のような場合、重複なしシートは、どうなりますか?
 >AAAは、グループ内で合算すると、数量はともに、60です!

そのような場合でも別のグループとして扱いたいと思っています。
警告もなくて大丈夫です。
知識として知りたいのですが、どのような方法で警告を行うことができるのでしょうか?


 >ウッシ様

コメントありがとうございます。

 >比較対象は品名、部品、数量の3つが一致した場合の、A列〜BI列の内容は完全に一致するのですか? 
 >品名、部品、数量の3つが一致しても、その他の列のデータが一致しない場合は、どの分のデータを 
 >コピーするのですか? 

品名、部品、数量が一致してもその他の列は完全に一致しない場合はあります。
あくまで備考なので、半角全角の表記ゆれや記入漏れなどがある状態です。

ですが、
品名  |部品 |数量 |備考
電話  |AAA |60  |あいう
     |BBB|10  | かきく
電話  |AAA |60  |あいうえお
     |BBB|10  |かきくけこ

といった場合であっても

品名  |部品 |数量 |備考
電話  |AAA |60  |あいう
     |BBB|10  | かきく

のように、いずれか(可能であれば一番初めに出てきたグループ)の
1つに集約することができれば問題ありません。
必要な情報としては「品名、部品、数量」の3つですが
その他の備考の列も参考程度にコピーしたい、といった状態です。
(たいよう) 2017/02/17(金) 09:38


こんにちは

Sub test_1()

    Dim tSh As Worksheet
    Dim pSh As Worksheet
    Dim uBk As Workbook
    Dim uSh As Worksheet
    Dim vSh As Worksheet
    Dim r   As Range
    Dim t   As Range
    Dim h   As Long
    Dim i   As Long
    Dim j   As Long

    Application.ScreenUpdating = False

    Set uBk = Workbooks.Add
    Set uSh = uBk.Worksheets(1)
    uSh.Name = "一覧"
    Set tSh = uBk.Worksheets(2)
    Set vSh = uBk.Worksheets(3) '新規作成されたブックにはデフォルトでシートが3枚有るとする

    ThisWorkbook.Activate

    tSh.Range("A1:AI1").Value = Worksheets(2).Range("A1:AI1").Value
    tSh.Range("AJ1").Value = "グループ"
    tSh.Range("AK1").Value = "部品グループ"

    With tSh
        For h = 2 To Worksheets.Count - 6
            Set pSh = Worksheets(h)
            Intersect(pSh.Range("A:AI"), pSh.UsedRange).Offset(1).Copy
            .Range("D" & Rows.Count).End(xlUp).Offset(1, -3).PasteSpecial xlPasteValues
        Next
        .Range("A:A").Copy .Range("AL1")
        .Range("D:D").Copy .Range("AM1")
        .Range("G:G").Copy .Range("AN1")

        .Range("H:AI").ColumnWidth = 0.77

        With .Range("AJ2:AJ" & .Range("D" & Rows.Count).End(xlUp).Row)
            .Formula = "=IF(A2<>"""",ROW(A1),IF(D2="""","""",AJ1))"
            .Offset(, 1).Formula = "=IF(A2<>"""",A2&TEXT(ROW(A1),""000000""),IF(D2="""","""",AK1))"
            .Resize(, 2).Value = .Resize(, 2).Value
        End With

        .Sort.SortFields.Clear
        .Sort.SortFields.Add Key:=.Range("AK:AK" _
            ), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .Sort.SortFields.Add Key:=.Range("AL:AL" _
            ), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
        .Sort.SortFields.Add Key:=.Range("AM:AM" _
            ), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .Sort.SortFields.Add Key:=.Range("AN:AN" _
            ), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        With .Sort
            .SetRange tSh.Range("A:AN")
            .Header = xlYes
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
        .Sort.SortFields.Clear
        .Sort.SortFields.Add Key:=.Range("AK:AK" _
            ), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .Sort.SortFields.Add Key:=.Range("AM:AM" _
            ), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .Sort.SortFields.Add Key:=.Range("AN:AN" _
            ), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        With .Sort
            .SetRange tSh.Range("B:AN")
            .Header = xlYes
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
        .Range("A:A").Copy .Range("AL1")
        .UsedRange.Copy vSh.Range("A1")
        .Activate

        For Each r In .Range("AL2", .Range("AJ" & Rows.Count).End(xlUp).Offset(, 2))
            If r.Value <> "" Then
                Set t = r.End(xlToRight).Offset(, 1)
            Else
                t.Resize(, 2).Value = r.Offset(, 1).Resize(, 2).Value
                Set t = t.End(xlToRight).Offset(, 1)
                r.EntireRow.ClearContents
            End If
        Next
        .UsedRange.Sort _
            Key1:=.Range("AL1"), Order1:=xlAscending, _
            Header:=xlYes

        .Columns("AK:AK").Delete

        .Range("AK1").Resize( _
            .Range("AJ" & Rows.Count).End(xlUp).Row, _
            .UsedRange.Columns.Count - .Range("AJ1").Column).AdvancedFilter _
            Action:=xlFilterInPlace, Unique:=True

        uSh.Range("A1:AI1").Value = .Range("A1:AI1").Value

        .Range("AJ:AJ").SpecialCells(xlCellTypeVisible).Copy vSh.Range("AP1")

        vSh.Range("A1").CurrentRegion.AdvancedFilter _
            Action:=xlFilterCopy, _
            CriteriaRange:=vSh.Range("AP1").CurrentRegion, _
            CopyToRange:=uSh.Range("A1:AI1"), Unique:=False

        Application.DisplayAlerts = False
        .Delete
        vSh.Delete
        Application.DisplayAlerts = True
    End With

    uBk.SaveAs Filename:=CreateObject("WScript.Shell").SpecialFolders("Desktop") & _
        "\商品一覧_" & Format(Now(), "yyyymmdd hhmmss") & ".xlsx", _
        FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False

    uBk.Close

    Application.ScreenUpdating = True

End Sub

品名、部品の列のデータの後ろにスペースが付いていたり、
品名の列の空のセルにスペースが入っているような事が無いのが前提です。

(ウッシ) 2017/02/17(金) 12:22


 >ウッシ様

コードの掲載、ありがとうございます。
早速実行したのですがどうやら3つ問題があるようで…

1つめはExcel2016で新しいブックを作成した際にはシートは1つしか作成されていないようで、
9行目でエラーが発生してしまいました。
デバッグの際にシートを2つ作成することで対応しました。

2つめは、実行は完了したのですが、
作成できたブックを開いてみると重複している商品が複数存在しているようでした。

 >品名、部品の列のデータの後ろにスペースが付いていたり、 
 >品名の列の空のセルにスペースが入っているような事が無いのが前提です。 

とのことだったので内容を見てみたのですが、
検索を行っても品名も部品の列にもスペースは入っていないようで…

現在、A3〜BI42の内容は

品名  |部品 |数量 |備考
電話  |AAA |60  |あいう
     |BBB|10  | かきく
電話  |AAA |60  |あいうえお
     |BBB|10  |かきくけこ

という状態で、グループの先頭行以外の品名は空の状態なのですが、そこが原因でしょうか?

3つ目は、A3〜BI42以外の行もコピーされているようでした。
記入を忘れていたのですが、
A3〜BI42では非表示になっている行、列も存在しています。
その辺りも関係してくるのでしょうか?

(たいよう) 2017/02/17(金) 14:38


こんにちは

シートが1つだったら2つ追加するコードを加えればいいです。

グループの先頭行以外の品名は空の状態が前提ですが、
空のように見えて、スペースが入っていたりしないですか?

BI列だったんですね、AI列と間違えました。

後だしの条件良く見てなかったです。
3行目からデータなんですね。

A3〜BI42 のデータの範囲内

も見落としてました。

なんか疲れる。

(ウッシ) 2017/02/17(金) 14:48


A1〜BI2 が見出しとなっており

というと、結合セルですか?

項目の有無も重要なので、正確に説明して下さい。

1行に項目名が入ってないとすると面倒なので、こちらで適宜項目名を
セットして処理するようにした方が楽かも。

(ウッシ) 2017/02/17(金) 14:51


こんにちは

Sub test_2()

    Dim tSh As Worksheet
    Dim pSh As Worksheet
    Dim uBk As Workbook
    Dim uSh As Worksheet
    Dim vSh As Worksheet
    Dim r   As Range
    Dim t   As Range
    Dim h   As Long
    Dim i   As Long
    Dim j   As Long

    Application.ScreenUpdating = False

    Set uBk = Workbooks.Add
    Set uSh = uBk.Worksheets(1)
    uSh.Name = "一覧"
    Set tSh = uBk.Worksheets.Add
    Set vSh = uBk.Worksheets.Add

    ThisWorkbook.Activate

    tSh.Range("A1:BI1").Formula = "=""dummy""&COLUMN(A1)"
    tSh.Range("A1:BI1").Value = tSh.Range("A1:BI1").Value
    tSh.Range("A1").Value = "品名"
    tSh.Range("D1").Value = "部品"
    tSh.Range("G1").Value = "数量"
    tSh.Range("BJ1").Value = "グループ"
    tSh.Range("BK1").Value = "部品グループ"

    With tSh
        For h = 2 To Worksheets.Count - 6
            Set pSh = Worksheets(h)
            pSh.Range("A3:BI42").Copy
            .Range("D" & Rows.Count).End(xlUp).Offset(1, -3).PasteSpecial xlPasteValues
        Next
        .Range("A:A").Replace " ", ""
        .Range("A:A").Replace " ", ""
        .Range("A:A").Copy .Range("BL1")
        .Range("D:D").Copy .Range("BM1")
        .Range("G:G").Copy .Range("BN1")

        .Range("H:BI").ColumnWidth = 0.77

        With .Range("BJ2:BJ" & .Range("D" & Rows.Count).End(xlUp).Row)
            .Formula = "=IF(A2<>"""",ROW(A1),IF(D2="""","""",BJ1))"
            .Offset(, 1).Formula = "=IF(A2<>"""",A2&TEXT(ROW(A1),""000000""),IF(D2="""","""",BK1))"
            .Resize(, 2).Value = .Resize(, 2).Value
        End With

        .Sort.SortFields.Clear
        .Sort.SortFields.Add Key:=.Range("BK:BK" _
            ), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .Sort.SortFields.Add Key:=.Range("BL:BL" _
            ), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
        .Sort.SortFields.Add Key:=.Range("BM:BM" _
            ), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .Sort.SortFields.Add Key:=.Range("BN:BN" _
            ), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        With .Sort
            .SetRange tSh.Range("A:BN")
            .Header = xlYes
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
        .Sort.SortFields.Clear
        .Sort.SortFields.Add Key:=.Range("BK:BK" _
            ), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .Sort.SortFields.Add Key:=.Range("BM:BM" _
            ), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .Sort.SortFields.Add Key:=.Range("BN:BN" _
            ), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        With .Sort
            .SetRange tSh.Range("B:BN")
            .Header = xlYes
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
        .Range("A:A").Copy .Range("BL1")
        .UsedRange.Copy vSh.Range("A1")
        .Activate

        For Each r In .Range("BL2", .Range("BJ" & Rows.Count).End(xlUp).Offset(, 2))
            If r.Value <> "" Then
                Set t = r.End(xlToRight).Offset(, 1)
            Else
                t.Resize(, 2).Value = r.Offset(, 1).Resize(, 2).Value
                Set t = t.End(xlToRight).Offset(, 1)
                r.EntireRow.ClearContents
            End If
        Next
        .UsedRange.Sort _
            Key1:=.Range("BL1"), Order1:=xlAscending, _
            Header:=xlYes

        .Columns("BK:BK").Delete

        .Range("BK1").Resize( _
            .Range("BJ" & Rows.Count).End(xlUp).Row, _
            .UsedRange.Columns.Count - .Range("BJ1").Column).AdvancedFilter _
            Action:=xlFilterInPlace, Unique:=True

        uSh.Range("A1:BI1").Value = .Range("A1:BI1").Value

        .Range("BJ:BJ").SpecialCells(xlCellTypeVisible).Copy vSh.Range("BP1")

        vSh.Range("A1").CurrentRegion.AdvancedFilter _
            Action:=xlFilterCopy, _
            CriteriaRange:=vSh.Range("BP1").CurrentRegion, _
            CopyToRange:=uSh.Range("A1:BI1"), Unique:=False

        Application.DisplayAlerts = False
        .Delete
        vSh.Delete
        Application.DisplayAlerts = True
    End With

    uBk.SaveAs Filename:=CreateObject("WScript.Shell").SpecialFolders("Desktop") & _
        "\商品一覧_" & Format(Now(), "yyyymmdd hhmmss") & ".xlsx", _
        FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False

    uBk.Close

    Application.ScreenUpdating = True

End Sub

品名、部品、数量以外の項目名は適当に設定しました。

非表示の行、列は実際どのようになっているのかわかりませんが、こちらで設定した

非表示行列は結果に影響しない事を確認してあります。

(ウッシ) 2017/02/17(金) 15:13


Sub main()
'前提:Sheet1,Sheet2のA列=品名、B列=部品、C列=数量。1行目は見出し

    Dim sht As Variant, dic As Object, r As Range, s_r As Range, e_r As Range, temps As String
    Set dic = CreateObject("scripting.dictionary")
    For Each sht In ThisWorkbook.Worksheets
        If sht.Name = "wk" Or sht.Name = "result" Then Application.DisplayAlerts = False: sht.Delete
    Next sht
    Sheets.Add before:=Sheets("Sheet1")
    ActiveSheet.Name = "wk"
    Sheets.Add before:=Sheets("Sheet1")
    ActiveSheet.Name = "result"
    For Each sht In Array(Sheets("Sheet1"), Sheets("Sheet2"))
        Set r = sht.Range("A3").Resize(, 3)
        Set s_r = r.Offset(-1)
        Do
            If Application.WorksheetFunction.CountA(r) = 3 Then
                Set e_r = r.Offset(-1)
                temps = sub1(Range(s_r, e_r))
                If dic(temps) = False Then
                    Range(s_r, e_r).Copy Sheets("result").Range("C" & Rows.Count).End(xlUp).Offset(1, -2)
                    dic(sub1(Range(s_r, e_r))) = True
                End If
                Set s_r = r
            End If
            Set r = r.Offset(1)
            If sht.Range("C" & Rows.Count).End(xlUp).Row < r.Row Then
                Set e_r = r.Offset(-1)
                temps = sub1(Range(s_r, e_r))
                If dic(temps) = False Then
                    Range(s_r, e_r).Copy Sheets("result").Range("C" & Rows.Count).End(xlUp).Offset(1, -2)
                    dic(sub1(Range(s_r, e_r))) = True
                End If
                Exit Do
            End If
        Loop
    Next sht
    Sheets("result").Range("A1:C1").Value = Array("品名", "部品", "数量")
End Sub

Function sub1(arg As Range) As String

    Dim c As Range
    arg.Copy Sheets("wk").Range("A1")
    Sheets("wk").Range("B1:C" & Rows.Count).Sort Key1:=Sheets("wk").Range("B1"), Order1:=xlAscending, Header:=xlNo
    For Each c In Sheets("wk").UsedRange
        sub1 = sub1 & Chr(10) & c.Address(0, 0) & Trim(c.Value)
    Next c
End Function
(mm) 2017/02/17(金) 15:19

 >ウッシ様

再度のコード記載もありがとうございます。
これから実行してみようと思います。

前提の条件の記載が足りず申し訳ないです…。
お手数ですが、後出しの条件も見ていただけると助かります。

 >グループの先頭行以外の品名は空の状態が前提ですが、 
 >空のように見えて、スペースが入っていたりしないですか? 

半角、全角問わずスペースで一括の検索をしてみたのですが…改めて検索を行ってみます。

 >A1〜BI2が見出しとなっており 
 >というと、結合セルですか? 

いえ、1〜42行の見出しと商品を記載している行にはセル結合は行っていません。
43行目以降のセルに対しては行、列のセル結合を行っている場合もあります。

 >1行に項目名が入ってないとすると面倒なので、こちらで適宜項目名を 
 >セットして処理するようにした方が楽かも。

現在のシートの内容は、

2  |月  |17  |日  |2017年|(空セル)|(空セル)|(空セル)|…|(空セル)|
品名|備考|備考|部品|備考 |備考  |数量  |備考  |…|備考N  |
電話|   |   |AA |    |     |2    |中古   |…|○○年製|

	・
	・

といったようになっており、
1行目にはシートが作成された日付(列はシート共通ですが、年月はバラバラです)、
2行目では、1つの列に1つの項目を設定しており、。
3行目以降に項目に対応するデータが入っています。


 >mm様

コードの記載、ありがとうございます。
実データと見比べつつ、実行してみたいと思います。
(たいよう) 2017/02/17(金) 16:05


 >たいよう さん

 >警告もなくて大丈夫です。 
 >知識として知りたいのですが、どのような方法で警告を行うことができるのでしょうか? 

 MsgBoxで、次のような表示を出そうかと思っていました。
 重複が見つかった、はじめのグループだけを表示して、処理を途中終了させる。
 〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓
 同じグループ内で、部品名が重複しています。
 シート名:2月
 重複セル:D7,D9,D14
 〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓

 出力ファイルのセルの幅、高さについて、このようにしたいなど希望はありますか?
 幅については、次のコードで自動調整しています。
 sh.Columns("A:BN").AutoFit
 _
 _
 >1行目にはシートが作成された日付(列はシート共通ですが、年月はバラバラです)

 上記記述のSampleプロシージャの処理では、出力ファイルの1行目(見出し)は、
 データ抽出元シート(左端にある該当シート)の1行目の値を利用してます。

 仮に、出力ファイル作成日が、「2017年2月18日」だとしたら、
 出力ファイルの1行目のA〜E列は、次のようにした方がいいですか?

    |[A]|[B]|[C]|[D]|[E]   
 [1]|  2|月 | 18|日 |2017年

(マリオ) 2017/02/18(土) 06:46


 >たいよう さん

 >商品と商品の間は空白行が入っているもの、いないものも混在しています。 
 「別グループに切り替わる行に、空白行が入っているもの、いないものも混在しています」ですかね?
 見分け方としては、D列(またはG列)に着目すればいいんですかね?

 こんな感じですかね?
 A〜BI列、1,2行目は見出し、3〜42行目がデータ。43行目以降は、メモ書きなので無視する
 (★箇所:何かしらデータが入ってる)
 4行目→5行目で、別グループに切り替わるが、4行目と5行目の間には、空白行がない。

 別グループに切り替わる間の行ですが、空白行が1行じゃなくて、2行とか3行なんてとこもありますか?
 不要シート7枚以外のシートですが、何枚ぐらいあります?10枚?20枚?30枚?

     |[A] |[B] |[C] |[D]   |[E]   |[F] |[G] |[H] |[・]|[BI] 
 [1] |   2|月  |  18|日    |2017年|    |    |    |    |    
 [2] |品名|備考|備考|部品  |備考  |備考|数量|備考|…  |備考
 [3] |電話|★  |★  |AAA|★    |★  |  60|★  |…  |★  
 [4] |    |★  |★  |BBB|★    |★  |  80|★  |…  |★  
 [5] |電話|★  |★  |AAA|★    |★  |  60|★  |…  |★  
 [6] |    |★  |★  |BBB|★    |★  |  10|★  |…  |★  
 [7] |    |★  |★  |CCC|★    |★  |  50|★  |…  |★  
 [8] |    |    |    |      |      |    |    |    |    |    
 [9] |電話|★  |★  |AAA|★    |★  |  60|★  |…  |★  
 [10]|    |★  |★  |BBB|★    |★  |  80|★  |…  |★  
 [11]|    |    |    |      |      |    |    |    |    |    
 [12]|電話|★  |★  |AAA|★    |★  |  60|★  |…  |★  
 [・]|    |…  |…  |…    |…    |…  |…  |…  |…  |…  
 [42]|    |★  |★  |BBB|★    |★  |  80|★  |…  |★  
(マリオ) 2017/02/18(土) 07:23

回答が遅くなり申し訳ありません。
改めまして、皆さま本当にありがとうございます。

 >ウッシ様

コードの再掲載ありがとうございました。
実行は問題なく終了したのですが、やはり重複している商品が複数存在しているようでした。
データを見ても空白は存在しないのですが、考えられる問題はほかにありますでしょうか?


 >マリオ様

コードの掲載、ありがとうございました。
実行したのですが、
コードの124行目、

 >.SortFields.Add Key:=Range("D" & s_row) '第1優先

の部分で「実行時エラー:1004」
「アプリケーション定義またはオブジェクト定義のエラーです」
と表示されてしまいました。
問題の原因としては何が考えられるでしょうか?
途中まで作成されたエクセルでエラーの起こった行を確認したのですが、
商品名や部品が空白であったり、といったことはなく、コピーされているように思えたのですが…。

 >出力ファイルのセルの幅、高さについて、このようにしたいなど希望はありますか?
いえ、高さは自動調整していただいているなら特に希望はありません。ありがとうございます。

 >仮に、出力ファイル作成日が、「2017年2月18日」だとしたら、
 >出力ファイルの1行目のA〜E列は、次のようにした方がいいですか?
可能であればそのようにお願いしたいです。

 >見分け方としては、D列(またはG列)に着目すればいいんですかね?
 >こんな感じですかね?
はい、まさしくその通りです。

 >別グループに切り替わる間の行ですが、空白行が1行じゃなくて、2行とか3行なんてとこもありますか?
はい、確認をしたのですが、2行のものは確認できました。
今後も2、3行の空白行は存在しそうです。

 >不要シート7枚以外のシートですが、何枚ぐらいあります?10枚?20枚?30枚?
30枚前後の想定です。

(たいよう) 2017/02/20(月) 20:15


 > たいようさん

 >.SortFields.Add Key:=Range("D" & s_row) '第1優先
 >の部分で「実行時エラー:1004」 
 >「アプリケーション定義またはオブジェクト定義のエラーです」 
 >と表示されてしまいました。 

 Rangeの前に「sh.」を追加してみてください。
 **********************************************************
    .SortFields.Add Key:=Range("D" & s_row) '第1優先
    .SortFields.Add Key:=Range("G" & s_row) '第2優先
 **********************************************************
 を
 〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓
    .SortFields.Add Key:=sh.Range("D" & s_row) '第1優先
    .SortFields.Add Key:=sh.Range("G" & s_row) '第2優先
 〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓
 と記述。これで、どうなりますか?
 _
 _
 _

 >>仮に、出力ファイル作成日が、「2017年2月18日」だとしたら、
 >>出力ファイルの1行目のA〜E列は、次のようにした方がいいですか?
 >可能であればそのようにお願いしたいです。

 コードのはじめの方に、
 *****************************
     m_flag = True
         End If
     Next s
 ******************************
 とありますので、その次行に、

    '〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓
     Dim Date1 As Date
     Date1 = Date
     With newbk.Sheets(1)
         .Range("A1") = Month(Date1)
         .Range("B1") = "月"
         .Range("C1") = Day(Date1)
         .Range("D1") = "日"
         .Range("E1") = Year(Date1) & "年"
     End With
    '〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓
 を追加してください。

 また、コードのうしろの方に、
 ********************************************************
 fname2 = fname & Format(Date, "yyyymmdd") & ".xlsx"
 ********************************************************
 とありますから、DateをDate1と書き換えて、次のようにしてください。
    '〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓
     fname2 = fname & Format(Date1, "yyyymmdd") & ".xlsx"
    '〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓 _
 _
 _
 _

 (マリオ) 2017/02/18(土) 06:45 のコードを一部編集、追加しました。
 〓〓〓〓で挟まれた行が、編集または、追加したコードです。
 _
 _
 _

 >高さは自動調整していただいているなら特に希望はありません。
 幅については、マクロで次のように記述していますが、高さについては、
 マクロで何も記述していません。
 sh.Columns("A:BN").AutoFit '列幅自動調整

 ですが、高さは、マクロで記述しなくても、自動調整されるみたいです。

(マリオ) 2017/02/20(月) 20:24


 >たいよう さん

 ***************************************************************
     |[A] |[B] |[C] |[D]   |[E]   |[F] |[G] |[H] |[・]|[BI]  
 [4] |    |    |    |      |      |    |    |    |    |    
 [5] |電話|★  |★  |AAA|★    |★  |  60|★  |…  |★  
 [6] |    |★  |★  |BBB|★    |★  |  10|★  |…  |★  
 [7] |    |★  |★  |CCC|★    |★  |  50|★  |…  |★  
 [8] |    |    |    |      |      |    |    |    |    |    
 ***************************************************************
 と記述すべきグループデータがあるとします。

 ここで、A5に「電話」と入力すべきなのに、
 入力しなかった(または、入力したが、間違ってdeleteしてしまった)場合、
 4行目と8行目が空白なら、これは明らかにおかしいので、警告した方がいいですかね?

 また、A5に「電話」と入力すべきなのに、A6の方に間違って「電話」と入力してしまった場合(A5,A7は空白)、
 4行目と8行目が空白なら、明らかにおかしいので、警告した方がいいですかね?

 このような、おかしなデータの場合、プログラムは誤作動します。

(マリオ) 2017/02/20(月) 21:52


こんばんは

やはりデータが違うのかも?

新規ブックに、

Sub テストデータ()
  Dim i As Long
  With ThisWorkbook
    .Worksheets(.Worksheets.Count).Activate
    Sheets.Add After:=ActiveSheet
    Sheets.Add After:=ActiveSheet
    Sheets.Add After:=ActiveSheet
    Sheets.Add After:=ActiveSheet
    Sheets.Add After:=ActiveSheet
    Sheets.Add After:=ActiveSheet
    Sheets.Add After:=ActiveSheet
    Sheets.Add After:=ActiveSheet
    Application.DisplayAlerts = False
    For i = .Worksheets.Count To 1 Step -1
      If i > 9 Then
        .Worksheets(i).Delete
      End If
    Next
    .Worksheets(3).UsedRange.ClearContents
    With .Worksheets(2)
      .UsedRange.ClearContents
      .Range("A2").Value = "dummy1"
      .Range("A2").AutoFill Destination:=.Range("A2:BI2"), Type:=xlFillDefault
      .Range("A2").Value = "品名"
      .Range("D2").Value = "部品"
      .Range("G2").Value = "数量"
      .Range("A2:BI2").Copy ThisWorkbook.Worksheets(3).Range("A2")
      .Range("A3").Value = "電話"
      .Range("A6").Value = "パソコン"
      .Range("A9").Value = "電話"
      .Range("B3").Value = "1"
      .Range("B4").Value = "2"
      .Range("B6").Value = "4"
      .Range("B7").Value = "5"
      .Range("B9").Value = "7"
      .Range("B10").Value = "8"
      .Range("B11").Value = "9"
      .Range("D3").Value = "AAA"
      .Range("D4").Value = "BBB"
      .Range("D6").Value = "BBB"
      .Range("D7").Value = "CCC"
      .Range("D9").Value = "AAA"
      .Range("D10").Value = "BBB"
      .Range("D11").Value = "CCC"
      .Range("G3").Value = "60"
      .Range("G4").Value = "80"
      .Range("G6").Value = "70"
      .Range("G7").Value = "20"
      .Range("G9").Value = "60"
      .Range("G10").Value = "10"
      .Range("G11").Value = "50"
    End With
    With .Worksheets(3)
      .Range("A3").Value = "パソコン"
      .Range("A6").Value = "電話"
      .Range("A8").Value = "電話"
      .Range("B3").Value = "1"
      .Range("B4").Value = "2"
      .Range("B6").Value = "4"
      .Range("B7").Value = "5"
      .Range("B8").Value = "6"
      .Range("B9").Value = "7"
      .Range("D3").Value = "CCC"
      .Range("D4").Value = "BBB"
      .Range("D6").Value = "AAA"
      .Range("D7").Value = "BBB"
      .Range("D8").Value = "AAA"
      .Range("D9").Value = "BBB"
      .Range("G3").Value = "20"
      .Range("G4").Value = "70"
      .Range("G6").Value = "60"
      .Range("G7").Value = "10"
      .Range("G8").Value = "60"
      .Range("G9").Value = "80"
    End With
    
  End With

End Sub

でテストデータを作成し、先に提示した Sub test_2() もセットしてから
名前を付けて保存し、test_2を実行してみて下さい。

(ウッシ) 2017/02/20(月) 22:02


 >マリオ様

 >Rangeの前に「sh.」を追加してみてください。
追加をしたのですが、変化はありませんでした。同じ行で止まってしまうようです。
D列の該当しているセルを確認したのですが、やはり値は入っているようで…
引用元のシートを確認してもおかしなデータ、というわけでもないようです。

 >追記
シートを削除したりして試していたのですが、
どうやら33グループにさしかかった際にエラーになってしまうようです。
関係はありますでしょうか?
33グループより少ない場合は無事に処理が終了します。
イミディエイトウィンドウで削除対象を確認した際は
どうやら重複した商品が削除対象になっているようです!

 >4行目と8行目が空白なら、これは明らかにおかしいので、警告した方がいいですかね?
警告が可能なのであれば警告をお願いしたいです。


 >ウッシ様
テストデータの作成までありがとうございます。
テストデータを作成したのちに実行したところ、
重複もなく、無事に4件分が一覧に表示されました。
改めて行、列の数なども含めてデータの確認を行ってみます。

(たいよう) 2017/02/21(火) 19:20


 >たいよう さん
 >重複もなく、無事に4件分が一覧に表示されました。
 ウッシさんの出力結果は、次のようだと思いますが、同じですか?
 (ただし、見出しのdummy2〜dummy61の文字列を除く)
 コードは詳しく見てませんが、ウッシさんのコードSub test_2()は、処理速度が速いですね。
 *************************************************
     |[A]     |[B]|[C]|[D] |[E]|[F]|[G] 
 [1] |品名    |   |   |部品|   |   |数量
 [2] |パソコン|  4|   |BBB |   |   |  70
 [3] |        |  5|   |CCC |   |   |  20
 [4] |電話    |  1|   |AAA |   |   |  60
 [5] |        |  2|   |BBB |   |   |  80
 [6] |電話    |  7|   |AAA |   |   |  60
 [7] |        |  8|   |BBB |   |   |  10
 [8] |        |  9|   |CCC |   |   |  50
 [9] |電話    |  4|   |AAA |   |   |  60
 [10]|        |  5|   |BBB |   |   |  10
 *************************************************

 ウッシさんのテストデータを使用して、
 Sampleプロシージャ「(マリオ) 2017/02/18(土) 06:46」 もセットしてから 名前を付けて保存し、
 Sampleプロシージャを実行してみて下さい。
 次のように、4件分が一覧に表示されると思います。同じですか?
 同じにならないなら、Sampleプロシージャを「(マリオ) 2017/02/18(土) 06:46」から、コピペし直してみてください。
 *************************************************
     |[A]     |[B]|[C]|[D]|[E]   |[F]|[G]
 [1] |       2|月 | 22|日 |2017年|   |   
 [2] |        |   |   |   |      |   |   
 [3] |電話    |  1|   |AAA|      |   | 60
 [4] |        |  2|   |BBB|      |   | 80
 [5] |パソコン|  4|   |BBB|      |   | 70
 [6] |        |  5|   |CCC|      |   | 20
 [7] |電話    |  7|   |AAA|      |   | 60
 [8] |        |  8|   |BBB|      |   | 10
 [9] |        |  9|   |CCC|      |   | 50
 [10]|電話    |  4|   |AAA|      |   | 60
 [11]|        |  5|   |BBB|      |   | 10
 *************************************************
(マリオ) 2017/02/22(水) 11:52

 >たいよう さん
 >引用元のシートを確認してもおかしなデータ、というわけでもないようです。

 引用元のシートの参照元セルに★結合セルがないかを下記のマクロで
 チェックしてみてください。

 ■準備とマクロの実行について
 引用元のファイルをコピーして、デスクトップに置いてください。
 ファイル名は、【引用元.xlsm】とでもしておいてください。
 そのファイルに、非表示にしているシートがあれば、表示してから、
 不要なシート7枚を削除してください。

 次に、新規ブックで【他のブックの結合セルを探す.xlsm】を作成し、
 シート名「Sheet1」を作成してください。
 この新規ブックのmodule1に次のコードをコピペしてください。

 次に、保存済みの【引用元.xlsm】と
 保存済みの【他のブックの結合セルを探す.xlsm】だけを
 開いた状態にして、「Sub 結合セルを探す()」を実行してみてください。

 【他のブックの結合セルを探す.xlsm】のSheet1に結果が出力されますが、
 結合セルは、ありますか?

 Set myRng1 = sh.Range(sh.Cells(1, "A"), sh.Cells(42, "BI"))
 のコードで、★結合セル調査範囲を限定しています。

 *****************************************************************
 Option Explicit

 'このWorkbookを除き、すべての開いているWorkbookを対象とする
 Sub 結合セルを探す()
    Dim sh1 As Worksheet, myRng1 As Range
    Dim myDic As Object, myKey
    Dim k As Long, bk As Workbook, sh As Worksheet, c As Range
    Dim ct As Long, ct2 As Long, ct3 As Long
    Dim x As String, i As Long
    Dim msg As String, rc As Integer
    Set sh1 = ThisWorkbook.Sheets("Sheet1") '★シート名
    sh1.Range("A1", sh1.UsedRange).Clear
    sh1.Range("A1") = "ブック名"
    sh1.Range("B1") = "シート名"
    sh1.Range("C1") = "調査範囲"
    sh1.Range("D1") = "結合セル"
    Set myDic = CreateObject("Scripting.Dictionary")
   '-------------------------------------------------------
    k = 2
    For Each bk In Workbooks
        If bk.Name <> ThisWorkbook.Name Then
           ct3 = ct3 + 1
           sh1.Range("A" & k) = bk.Name
           Workbooks(bk.Name).Activate
           For Each sh In ActiveWorkbook.Worksheets
               sh1.Range("B" & k) = sh.Name
               Set myRng1 = sh.Range(sh.Cells(1, "A"), sh.Cells(42, "BI")) '★結合セル調査範囲を限定
               'Set myRng1 = sh.Range("A", sh.UsedRange)'★結合セル調査範囲を各々のシートの使用範囲にする
               sh1.Range("C" & k) = myRng1.Address(False, False)
               ct = 0
               For Each c In myRng1
                   If c.MergeCells Then
                      ct = ct + 1
                      ct2 = ct2 + 1
                      x = c.MergeArea.Address(False, False)
                      If Not myDic.Exists(x) Then myDic.Add x, ""
                   End If
               Next c
               If ct > 0 Then
                  myKey = myDic.Keys
                  For i = 0 To myDic.Count - 1
                      sh1.Range("D" & k) = myKey(i)
                      k = k + 1
                  Next i
                  myDic.RemoveAll '初期化(辞書)
               Else
                  sh1.Range("D" & k) = "結合セルはありません"
                  k = k + 1
               End If
           Next sh
        End If
    Next bk
   '-------------------------------------------------------
    sh1.Columns("A:D").AutoFit
    sh1.Columns("B").HorizontalAlignment = xlLeft
    sh1.Activate
    If ct3 = 0 Then
       msg = "このブック以外に開いているブックが1つもありません"
    ElseIf ct2 > 0 And ct3 > 0 Then
       msg = "結合セルが見つかりました"
    Else
       msg = "結合セルは見つかりませんでした"
    End If
    rc = MsgBox(msg, vbOKOnly, " 処理おわりました")
    Set sh1 = Nothing
    Set myDic = Nothing
    Set myRng1 = Nothing
 End Sub

(マリオ) 2017/02/22(水) 12:09


 >マリオ様

 >ウッシさんの出力結果は、次のようだと思いますが、同じですか?
 >次のように、4件分が一覧に表示されると思います。同じですか?
はい、それぞれマリオ様が書いているように表示されています。

 >【他のブックの結合セルを探す.xlsm】のSheet1に結果が出力されますが、
 >結合セルは、ありますか?
手順通り実行してみましたが、結合セルはなさそうです。


そしてすみません、
データの行列は「A3〜BI42」だと思っていたのですが、「A3〜BL42」の間違いでした。

(たいよう) 2017/02/22(水) 17:19


 >たいよう さん

 原因がわかりました。
 Sub Sample()にある
 「sh.Sort.SortFields.Clear」'並べ替え条件をクリア
 のコード記述位置が悪かったです。
 「sh.Sort.SortFields.Clear」を直後のiのForループの中に、入れたら解決しました。
 どうやら、エクセルの並べ替え条件は、32の条件までしか設定できないみたいですね。
 なので、33番目のグループを並べ替えようにしたときに、
 エラーとなったようです(33番目の条件を設定しようとしたため)。

 一グループの並び替えが終わったら、並べ替え条件をリセットして、条件の数をゼロにしてやらないといけない!

  後日、Sub Sample()「(マリオ) 2017/02/18(土) 06:45 」を修正予定です。
  後日、修正ファイルも、アップ予定です。

 >データの行列は「A3〜BI42」だと思っていたのですが、「A3〜BL42」の間違いでした。 

 了解しました。

(マリオ) 2017/02/22(水) 20:30


こんばんは

そんなはずは無いと思うのですが、Excel2016は、
フィルターオプションの重複無しが機能しないみたいです?

データの重複削除に変更しました。

Sub test_3()

    Dim aBk As Workbook
    Dim tSh As Worksheet
    Dim pSh As Worksheet
    Dim uBk As Workbook
    Dim uSh As Worksheet
    Dim vSh As Worksheet
    Dim r   As Range
    Dim t   As Range
    Dim h   As Long
    Dim i   As Long
    Dim j   As Long
    Dim a() As Variant

    Application.ScreenUpdating = False
    Set aBk = ThisWorkbook
    Set uBk = Workbooks.Add
    Set uSh = uBk.Worksheets(1)
    uSh.Name = "一覧"
    Set vSh = uBk.Worksheets.Add
    Set tSh = uBk.Worksheets.Add

    tSh.Range("A1:BL1").Formula = "=""dummy""&COLUMN(A1)"
    tSh.Range("A1:BL1").Value = tSh.Range("A1:BL1").Value
    tSh.Range("A1").Value = "商品名"
    tSh.Range("D1").Value = "部品"
    tSh.Range("G1").Value = "数量"
    tSh.Range("BM1").Value = "グループ"
    tSh.Range("BN1").Value = "部品グループ"

    With tSh
        For h = 2 To aBk.Worksheets.Count - 6
            Set pSh = aBk.Worksheets(h)
            pSh.Range("A3:BL42").Copy
            .Range("D" & Rows.Count).End(xlUp).Offset(1, -3).PasteSpecial xlPasteValues
        Next
        .Range("A:A").Copy .Range("BO1")
        .Range("D:D").Copy .Range("BP1")
        .Range("G:G").Copy .Range("BQ1")

        .Range("H:BL").ColumnWidth = 0.27

        With .Range("BM2:BM" & .Range("D" & Rows.Count).End(xlUp).Row)
            .Formula = "=IF(A2<>"""",ROW(A1),IF(D2="""","""",BM1))"
            .Offset(, 1).Formula = "=IF(A2<>"""",A2&TEXT(ROW(A1),""000000""),IF(D2="""","""",BN1))"
            .Resize(, 2).Value = .Resize(, 2).Value
        End With

        .Sort.SortFields.Clear
        .Sort.SortFields.Add Key:=.Range("BN:BN" _
            ), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .Sort.SortFields.Add Key:=.Range("BO:BO" _
            ), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
        .Sort.SortFields.Add Key:=.Range("BP:BP" _
            ), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .Sort.SortFields.Add Key:=.Range("BQ:BQ" _
            ), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        With .Sort
            .SetRange tSh.Range("A:BQ")
            .Header = xlYes
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
        .Sort.SortFields.Clear
        .Sort.SortFields.Add Key:=.Range("BN:BN" _
            ), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .Sort.SortFields.Add Key:=.Range("BP:BP" _
            ), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .Sort.SortFields.Add Key:=.Range("BQ:BQ" _
            ), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        With .Sort
            .SetRange tSh.Range("B:BQ")
            .Header = xlYes
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
        .Range("A:A").Copy .Range("BO1")
        .UsedRange.Copy vSh.Range("A1")
        .Activate

        For Each r In .Range("BO2", .Range("BM" & Rows.Count).End(xlUp).Offset(, 2))
            If r.Value <> "" Then
                Set t = r.End(xlToRight).Offset(, 1)
            Else
                t.Resize(, 2).Value = r.Offset(, 1).Resize(, 2).Value
                Set t = t.End(xlToRight).Offset(, 1)
                r.EntireRow.ClearContents
            End If
        Next
        .UsedRange.Sort _
            Key1:=.Range("BO1"), Order1:=xlAscending, _
            Header:=xlYes

        .Columns("BN:BN").Delete

        j = .Range("A1").CurrentRegion.Columns.Count - .Range("BM1").Column
        With .Range("A1").CurrentRegion
            ReDim a(0 To j - 1)
            For i = 0 To j - 1
                a(i) = i + Range("BN1").Column
            Next

            .RemoveDuplicates Columns:=(a), Header:=xlYes
        End With

        uSh.Range("A1:BL1").Value = .Range("A1:BL1").Value

        .Range("BM:BM").SpecialCells(xlCellTypeVisible).Copy vSh.Range("BS1")

        vSh.Range("A1").CurrentRegion.AdvancedFilter _
            Action:=xlFilterCopy, _
            CriteriaRange:=vSh.Range("BS1").CurrentRegion, _
            CopyToRange:=uSh.Range("A1:BL1"), Unique:=False

        Application.DisplayAlerts = False
        .Delete
        vSh.Delete
        Application.DisplayAlerts = True
    End With

    uSh.Range("A1:BL1").Value = aBk.Worksheets(2).Range("A2:BL2").Value

    uBk.SaveAs Filename:=CreateObject("WScript.Shell").SpecialFolders("Desktop") & _
        "\商品一覧_" & Format(Now(), "yyyymmdd hhmmss") & ".xlsx", _
        FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False

    uBk.Close

    Application.ScreenUpdating = True

End Sub

(ウッシ) 2017/02/22(水) 22:11


 >ウッシ様

 >データの重複削除に変更しました。 

コード記載ありがとうございます!!
確認したところ、どうやら重複がなくなって一意の商品が表示されているようです!
ありがとうございます!!

 >そんなはずは無いと思うのですが、Excel2016は、 
 >フィルターオプションの重複無しが機能しないみたいです? 
同じデータでtest_2とtest_3を実行したのですが、
やはりtest_2では商品が重複している状態で、test_3では重複がない状態になっていました。
Excel2016の仕様なのでしょうか…?

(たいよう) 2017/02/23(木) 08:45


こんにちは

フィルタオプションの重複削除は、Excel2010でも、こちらで作成したテストデータだと
上手く行きましたが、たいようさんのサンプルデータだとダメでした。

一つの商品名の塊の中に部品数が多いと、処理する列数が増えるのですが、その全ての
1行目に仮にでも項目名を付けないとフィルタオプションは上手く機能しないようです。
・・・当然かも。

Sub test_4()

    Dim aBk As Workbook
    Dim tSh As Worksheet
    Dim pSh As Worksheet
    Dim uBk As Workbook
    Dim uSh As Worksheet
    Dim vSh As Worksheet
    Dim r   As Range
    Dim t   As Range
    Dim h   As Long
    Dim i   As Long
    Dim j   As Long
    Dim a() As Variant

    Application.ScreenUpdating = False
    Set aBk = ThisWorkbook
    Set uBk = Workbooks.Add
    Set uSh = uBk.Worksheets(1)
    uSh.Name = "一覧"
    Set vSh = uBk.Worksheets.Add
    Set tSh = uBk.Worksheets.Add

    tSh.Range("A1:BL1").Formula = "=""dummy""&COLUMN(A1)"
    tSh.Range("A1:BL1").Value = tSh.Range("A1:BL1").Value
    tSh.Range("A1").Value = "商品名"
    tSh.Range("D1").Value = "部品"
    tSh.Range("G1").Value = "数量"
    tSh.Range("BM1").Value = "グループ"
    tSh.Range("BN1").Value = "部品グループ"

    With tSh
        For h = 2 To aBk.Worksheets.Count - 6
            Set pSh = aBk.Worksheets(h)
            pSh.Range("A3:BL42").Copy
            .Range("D" & Rows.Count).End(xlUp).Offset(1, -3).PasteSpecial xlPasteValues
        Next
        .Range("A:A").Copy .Range("BO1")
        .Range("D:D").Copy .Range("BP1")
        .Range("G:G").Copy .Range("BQ1")

        .Range("H:BL").ColumnWidth = 0.27

        With .Range("BM2:BM" & .Range("D" & Rows.Count).End(xlUp).Row)
            .Formula = "=IF(A2<>"""",ROW(A1),IF(D2="""","""",BM1))"
            .Offset(, 1).Formula = "=IF(A2<>"""",A2&TEXT(ROW(A1),""000000""),IF(D2="""","""",BN1))"
            .Resize(, 2).Value = .Resize(, 2).Value
        End With

        .Sort.SortFields.Clear
        .Sort.SortFields.Add Key:=.Range("BN:BN" _
            ), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .Sort.SortFields.Add Key:=.Range("BO:BO" _
            ), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
        .Sort.SortFields.Add Key:=.Range("BP:BP" _
            ), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .Sort.SortFields.Add Key:=.Range("BQ:BQ" _
            ), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        With .Sort
            .SetRange tSh.Range("A:BQ")
            .Header = xlYes
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
        .Sort.SortFields.Clear
        .Sort.SortFields.Add Key:=.Range("BN:BN" _
            ), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .Sort.SortFields.Add Key:=.Range("BP:BP" _
            ), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .Sort.SortFields.Add Key:=.Range("BQ:BQ" _
            ), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        With .Sort
            .SetRange tSh.Range("B:BQ")
            .Header = xlYes
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
        .Range("A:A").Copy .Range("BO1")
        .UsedRange.Copy vSh.Range("A1")
        .Activate

        For Each r In .Range("BO2", .Range("BM" & Rows.Count).End(xlUp).Offset(, 2))
            If r.Value <> "" Then
                Set t = r.End(xlToRight).Offset(, 1)
            Else
                t.Resize(, 2).Value = r.Offset(, 1).Resize(, 2).Value
                Set t = t.End(xlToRight).Offset(, 1)
                r.EntireRow.ClearContents
            End If
        Next
        .UsedRange.Sort _
            Key1:=.Range("BO1"), Order1:=xlAscending, _
            Header:=xlYes

        .Columns("BN:BN").Delete

' j = .Range("A1").CurrentRegion.Columns.Count - .Range("BM1").Column
' With .Range("A1").CurrentRegion
' ReDim a(0 To j - 1)
' For i = 0 To j - 1
' a(i) = i + Range("BN1").Column
' Next
'
' .RemoveDuplicates Columns:=(a), Header:=xlYes
' End With

        Stop

        With .Range("BN1").Resize(, _
                    .UsedRange.Columns.Count - .Range("BM1").Column)
            .Formula = "=""ddd""&COLUMN(A1)"
            .Value = .Value
        End With

        .Range("BN1").Resize( _
            .Range("BM" & Rows.Count).End(xlUp).Row, _
            .UsedRange.Columns.Count - .Range("BM1").Column).AdvancedFilter _
            Action:=xlFilterInPlace, Unique:=True

        uSh.Range("A1:BL1").Value = .Range("A1:BL1").Value

        .Range("BM:BM").SpecialCells(xlCellTypeVisible).Copy vSh.Range("BS1")

        vSh.Range("A1").CurrentRegion.AdvancedFilter _
            Action:=xlFilterCopy, _
            CriteriaRange:=vSh.Range("BS1").CurrentRegion, _
            CopyToRange:=uSh.Range("A1:BL1"), Unique:=False

        Application.DisplayAlerts = False
        .Delete
        vSh.Delete
        Application.DisplayAlerts = True
    End With

    uSh.Range("A1:BL1").Value = aBk.Worksheets(2).Range("A2:BL2").Value

    uBk.SaveAs Filename:=CreateObject("WScript.Shell").SpecialFolders("Desktop") & _
        "\商品一覧_" & Format(Now(), "yyyymmdd hhmmss") & ".xlsx", _
        FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False

    uBk.Close

    Application.ScreenUpdating = True

End Sub

こんな風に変更すると出来るかと思います。

(ウッシ) 2017/02/23(木) 10:28


 >ウッシ様
コードの再記載ありがとうございます!
stopの記載を見落としていて実行時にびっくりしてしまいましたが、
無事に重複がない状態に、全列表示されました!
勉強させていただきます!


 >マリオ様
 >エクセルの並べ替え条件は、32の条件までしか設定できないみたいですね。
32にそのような意味が…!解析ありがとうございます。

 >後日、Sub Sample()「(マリオ) 2017/02/18(土) 06:45 」を修正予定です。
 >後日、修正ファイルも、アップ予定です。
コメントも書いていただいて、すごく勉強になります!
楽しみにお待ちしております!

皆さま、本当にありがとうございます!!
(たいよう) 2017/02/23(木) 18:48


 >たいよう さん

 別モジュールに下記のコードを貼り付けてください。

 下記のマクロは、「人数」シートの「A1:A3」セルに、
 フォームコントロールのボタンを貼り付けています。
 Sample2プロシージャ【(マリオ) 2017/02/23(木) 19:15】
 をボタンにマクロ登録しています。

 あとは、「人数」シートの「A1:A3」セルに貼り付いたボタンを
 押せば、Sample2プロシージャが実行されます。

 '■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■
 Option Explicit

 '----- フォームコントロールのボタンに、Module1の「Sample2プロシージャ」をマクロ登録する

 Sub ボタン作成()
    Dim B As Object, btn1 As Button, sh As Worksheet
    Set sh = ThisWorkbook.Sheets("人数") '★シートを指定

    For Each B In sh.Buttons
        B.Delete 'ボタン全削除
    Next B
   '***************************************************************************
    With sh
         Set btn1 = .Buttons.Add(.Cells(1, 1).Left, _
                                 .Cells(1, 1).top, _
                                 .Range(.Cells(1, 1), .Cells(1, 1)).Width, _
                                 .Range(.Cells(1, 1), .Cells(3, 1)).Height)
    End With
    With btn1
        .OnAction = "Sample2" '★登録したいマクロの名前(プロシージャ名)
        .Text = "実行"
        .Name = "Button_1"
    End With
   '***************************************************************************
    Set sh = Nothing: Set btn1 = Nothing
 End Sub
 '■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■ 

(マリオ) 2017/02/23(木) 19:21


 >たいよう さん

 ★商品名で並び替えをしていません。
 さらに、商品名で並び替えた方がいいですか?

(マリオ) 2017/02/23(木) 21:18


 >マリオ様

コードの記載、zipのアップもありがとうございます!

 >★商品名で並び替えをしていません。
 >さらに、商品名で並び替えた方がいいですか?
可能であればお願いしたいです。

(たいよう) 2017/02/24(金) 08:48


こんにちは、たいようさん

Sub test_4 のフィルターオプション版は重複の削除に問題が有るようです。

マリオさんのアップされたファイル「■重複しないリストを作成_商品グループ_3.xlsm」で試すと、

ごはん         3001
ごはん         3002


小型コッペパン      2890
小型コッペパン      2891

がダブって残ってしまいます。

Sub test_3 は大丈夫なのでそちらを使って下さい。

あと、マリオさんのアップされたファイル「■重複しないリストを作成_商品グループ_3.xlsm」
で、実行ボタンで作成されたファイルと結果を照らし合わせたのですが、マリオさんの結果ファイルで、

そば米汁       3110

というデータが出来ているのですが、シート29の

りんご        3110

が、その上のそば米汁に組み入れられてしまっているようです。

その部分がマッチしませんでした。

(ウッシ) 2017/02/24(金) 10:56


 >ウッシ さん

 >りんご        3110 
 >が、その上のそば米汁に組み入れられてしまっているようです。 

 おかげで、コードミスに気づきました。ありがとうございます。
 元データは、75グループあるはずなのに、
 75グループ目を検出してないし…。

 *******************
 >マリオさんのアップされたファイル「■重複しないリストを作成_商品グループ_3.xlsm」で試すと、 
 >ごはん         3001 
 >ごはん         3002 
 >と 
 >小型コッペパン      2890 
 >小型コッペパン      2891 
 >がダブって残ってしまいます。 

 --------------------
 ダブって残ってしまいますとは、どういうことでしょうか?
 出力された一覧シートを見ると、次のようになっていて、
 重複してなうに思われるのですが。

    |[A]   |[B]|[C]|[D] 
 [3]|ごはん|   |   |3001
 [4]|      |   |   |3002

      |[A]        |[B]|[C]|[D] 
 [137]|小型コッペパン|   |   |2890
 [138]|           |   |   |2891

(マリオ) 2017/02/24(金) 15:27


こんにちは、マリオさん

Sub test_4 のフィルターオプション版の重複の削除の問題です。

そのテストデータで、test_4を実行すると

ごはん         3001
            3001
            3002
            3002


小型コッペパン      2890
            2890
            2891
            2891

というデータが出来てしまいトータルで4件データが多くなってしまうのです。

        .Range("BN1").Resize( _
            .Range("BM" & Rows.Count).End(xlUp).Row, _
            .UsedRange.Columns.Count - .Range("BM1").Column).AdvancedFilter _
            Action:=xlFilterInPlace, Unique:=True

が実行されても、何故かそれだけは集約されないのです。

デバッグ中にデータをごはんと小型コッペパンの部分は同じデータでコピペしてから
AdvancedFilterのコードを実行しても結果が変わらないので、もう諦めました。

マリオさんの環境で、test_4を実行すると、

    |[A]   |[B]|[C]|[D] 
 [3]|ごはん|   |   |3001
 [4]|      |   |   |3002

      |[A]        |[B]|[C]|[D] 
 [137]|小型コッペパン|   |   |2890
 [138]|           |   |   |2891

こうなったのでしょうか?

だとしたら、こちらの環境のせいかな・・・?

(ウッシ) 2017/02/24(金) 15:44


 >たいよう さん

 ファイルのやり取りに関する情報などは、
 一部、こちらの判断で、勝手に削除しました。
 後日、この掲示板を見た人が、何を言っているのか、分かりませんので。

 >ウッシさんのご指摘
 >りんご        3110 
 >が、その上のそば米汁に組み入れられてしまっているようです。

 で、コードミスに気づくことができました。
 下記の修正で、75グループちゃんと検出されるようになります。

 「重複しないリストを作成_商品グループ_3.xlsm」では、
 「〓で囲まれたIf文」が、「***で囲まれたIf文」の上にありました。
 これを逆にして、下記のように修正してください。

 ■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■
     For Each c In myRng
        '*******************************************************
         If c <> "" And c.Offset(0, -3) <> "" Then
            k = k + 1: ReDim Preserve frow(1 To k)
            frow(k) = c.Offset(-1, 0).Row '終了行(1つ上の行)

            ReDim Preserve srow(1 To k + 1)
            srow(k + 1) = c.Row '開始行(グループのトップ)
         End If
        '*******************************************************

        '〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓
         If c.Row = fr Then
            k = k + 1: ReDim Preserve frow(1 To k)
            frow(k) = fr '終了行
            Exit For
         End If
        '〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓
     Next c

(マリオ) 2017/02/24(金) 16:08


 >ウッシ さん
 AdvancedFilterは、見出しが1行のデータに対して、使っていたような…。
 なので、1行目を別の場所に退避させてから、1行目を削除(値の削除ではなく、行自体をなくす)

 それから、AdvancedFilter処理した後に、
 1行目挿入して、1行目のデータを戻すとかすればよいのでは?

(マリオ) 2017/02/24(金) 16:16


こんにちは、マリオさん

作業用シートでは既に1行目はコピーしていないのです。

一応、test_3で結果は出ているので、この現象についてはまた時間のある時に
検証してみます。

有難う御座いました。

(ウッシ) 2017/02/24(金) 16:44


 >たいよう さん

 最終のマクロコードを掲載します。(2017/2/26 13:36)

 マクロは、次の2つです。
 (1)sample5()
 (2)商品名の並び替え()

 (1)と(2)のコードは、別モジュールに貼り付けてください。
 _
 _
 (1)は、重複したグループを削除するマクロです。
 ☆印が付いている【11箇所】は、任意の文字列を設定してください。
 出力ファイル(商品一覧_yyyymmdd.xlsx)のシートは、次の2つです!
 ・「一覧」:重複データを削除した集約データを記述
 ・「Log」 :(A列)取得元シートのシート名
             (B列)取得元シートの行番号
             (C列)グループ番号
             (D列)「一覧」シートのA列
             (E列)「一覧」シートのD列
             (F列)「一覧」シートのG列
 ★「Log」シートの(D,E,F列):重複グル―プを赤で塗りつぶし
 _
 _
 (2)は、出力ファイル("商品一覧_yyymmdd.xlsx)を1つだけ
    開いた状態にしてから、マクロ実行してください。
    商品名をキーとして、グループ単位で並び替えます。
    並び替えは、「あいうえお順」です。
  「Log」シートは、並べ替えしてません。
  並び替えをしているのは「一覧」シートだけです。
 並び替え後は、「Log」シートは、あっても「一覧」シートと
 比較できないので、手作業で「log」シートを削除してください。

 ■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■ 
 '***** ↓sample5のコードは、ここから ****************************
 '取得元の各シートは、「A1:BL2」が見出しで、「A3:BL42」がデータとなっており、
 '品名がA列、部品がD列、数量がG列である。

 '☆箇所 → 任意の文字列、数値を設定してください。
 '●箇所 → 作業列に書き込みしています
 '★箇所 → 他のプロシージャをCallしています
 '◆箇所 → 出力ファイルを閉じたい場合は、先頭の「'」を削除してください

 Option Explicit

 Const fname As String = "商品一覧_"  '☆出力ファイルのファイル名(前半部分)
 Const sname As String = "一覧"       '☆出力ファイルのシート名

 Const s1 As String = "■■■"     '☆不要シート名(1)
 Const s2 As String = "■■■"     '☆不要シート名(2)
 Const s3 As String = "■■■"     '☆不要シート名(3)
 Const s4 As String = "■■■"     '☆不要シート名(4)
 Const s5 As String = "■■■"     '☆不要シート名(5)
 Const s6 As String = "■■■"     '☆不要シート名(6)
 Const s7 As String = "■■■"     '☆不要シート名(7)

 Const lc As String = "BL"       '☆取得元シートの取り扱い最終列
 Const lr As Long = 42           '☆取得元シートの取り扱い最終行

 Const zc As String = "K:K,L:L,O:R,U:U,X:AA,AC:AE,AH:AL,AN:AS,AW:BH,BJ:BL" '☆列幅をゼロにしたい列

 Sub sample5()
     Application.ScreenUpdating = False

    '------- 新規ブックを作成する -----------------------------------------------
     Dim newbk As Workbook, sh As Worksheet
     Set newbk = Workbooks.Add: newbk.Sheets(1).Name = sname
     Set sh = newbk.Sheets(1)

    '------- 新規ブックに、全データを貼り付ける ---------------------------------
     Dim s As Worksheet, flag As Boolean, r As Long
     Dim lr2 As Long, lc2 As Long
     lc2 = sh.Range(lc & "1").Column '列のアルファベットを列番号に変換
     lr2 = lr - 2 'データ行数(見出しの2行分を除く)

     Dim u As Long
     ReDim v(1 To lr, 0 To 0)
     For u = 1 To lr2
         v(u, 0) = u + 2 '【行番号】を配列に格納
     Next u

     r = 3 '貼付け行(初期値)
     For Each s In ThisWorkbook.Sheets
         If Not (s.Name = s1 Or s.Name = s2 Or s.Name = s3 Or s.Name = s4 Or _
                 s.Name = s5 Or s.Name = s6 Or s.Name = s7) Then
           '--- はじめのシートの見出しを貼り付ける
            If flag = False Then
               s.Range(s.Cells(1, "A"), s.Cells(2, lc2)).Copy sh.Range("A1")
               flag = True
            End If
           '--- データ(3行目以降)を貼り付ける
            s.Range(s.Cells(3, "A"), s.Cells(lr, lc2)).Copy sh.Range("A" & r)
           '--- 取得元シートのシート名と【行番号】を作業列に書き込む
            With sh
                .Range(.Cells(r, lc2 + 2), .Cells(r + lr2 - 1, lc2 + 2)) = s.Name '●
                .Range(.Cells(r, lc2 + 3), .Cells(r + lr2 - 1, lc2 + 3)) = v      '●
            End With
           '--- 次の貼り付け行を設定する
            r = r + lr2
         End If
     Next s

    '------- 新規ブックの見出しの編集する ---------------------------------------
     Dim Date1 As Date
     Date1 = Date
     With sh
         .Range("A1") = Month(Date1): .Range("B1") = "月"
         .Range("C1") = Day(Date1): .Range("D1") = "日"
         .Range("E1") = Year(Date1) & "年"
         .Cells(2, lc2 + 2) = "シート名" '取得元シートのシート名
         .Cells(2, lc2 + 3) = "行番号"   '取得元シートの行番号
     End With

    '------- チェック(新規ブックのD列最終行)-----------------------------------
     Dim fr As Long, msg As String, title As String
     fr = sh.Cells(Rows.Count, "D").End(xlUp).Row
     If fr <= 2 Then
        Application.ScreenUpdating = True
        title = " 終了します"
        msg = "データがありません"
        MsgBox msg, vbOKOnly, title
        newbk.Close SaveChanges:=False
        Application.ScreenUpdating = True: End
     End If

    '------- A,D,G列のTrim処理 --------------------------------------------------
     Dim myRng As Range, c As Range
     Set myRng = sh.Range(sh.Cells(3, "A"), sh.Cells(fr, "A")) 'A列3行目〜
     For Each c In myRng
         c = Trim(c)
         c.Offset(0, 3) = Trim(c.Offset(0, 3))
         c.Offset(0, 6) = Trim(c.Offset(0, 6))
     Next c

    '------- チェック(A列の品名が、グループのトップ位置に入力されているかどうか)---
     Dim sr As Long
     For Each c In myRng
        If c.Offset(0, 3) <> "" Then
           sr = c.Row '3行目以降のD列で、はじめに文字列が入っている行
           Exit For
        End If
     Next c

     Call 品名チェック(sh, sr, fr, lc2, newbk) '★

    '------- D列が空白になっている削除対象範囲(myRng2)を取得 -------------------
     Dim myRng2 As Range
     Set myRng = sh.Range(sh.Cells(3, "D"), sh.Cells(r - 1, "D")) 'D列の3〜(r-1)行
     For Each c In myRng
         If c = "" Then
            If myRng2 Is Nothing Then
               Set myRng2 = c.EntireRow
            Else
               Set myRng2 = Union(myRng2, c.EntireRow)
            End If
         End If
     Next c
     If Not myRng2 Is Nothing Then myRng2.Delete 'D列が空白になっている行を削除
     fr = sh.Cells(Rows.Count, "D").End(xlUp).Row 'D列最終行を再取得

    '------- 各グループの開始行と終了行を配列に格納 -----------------------------
     ReDim srow(1 To 1) As Long, frow(1 To 1) As Long
     Set myRng = sh.Range(sh.Cells(4, "D"), sh.Cells(fr, "D"))  'D列の4〜fr行

     srow(1) = 3
    'Debug.Print "開始行1" & "■" & srow(1)
     Dim k As Long

     If fr = 3 Then
        frow(1) = 3: k = 1: GoTo step1
     End If

     For Each c In myRng
         '*******************************************************
         If c <> "" And c.Offset(0, -3) <> "" Then
            k = k + 1: ReDim Preserve frow(1 To k)
            frow(k) = c.Offset(-1, 0).Row '終了行(1つ上の行)
           'Debug.Print "終了行" & k & "■" & frow(k)
            ReDim Preserve srow(1 To k + 1)
            srow(k + 1) = c.Row '開始行(グループのトップ)
           'Debug.Print "開始行" & k + 1 & "■" & srow(k + 1)
         End If
        '*******************************************************

        '〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓
         If c.Row = fr Then
            k = k + 1: ReDim Preserve frow(1 To k)
            frow(k) = fr '終了行
            'Debug.Print "終了行" & k & "■" & frow(k)
            Exit For
         End If
        '〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓
     Next c

step1:

    '------- A列に品名を記述する ------------------------------------------------
     Set myRng = sh.Range(sh.Cells(3, "A"), sh.Cells(fr, "A")) 'A列3行目〜
     For Each c In myRng
         If c = "" And c.Offset(0, 3) <> "" Then
            c = c.Offset(-1, 0)
         End If
     Next c

     '------- 各グループを並び替え、および作業列にグループ番号を記述 ------------
     Dim i As Long, s_row As Long, f_row As Long
     For i = 1 To k
         sh.Sort.SortFields.Clear '並べ替え条件をクリア(リセットする)
         s_row = srow(i)
         f_row = frow(i)
        '--- 各グループを並び替え
         With sh.Sort
             '.SortFields.Add Key:=sh.Range("D" & s_row & ":" & "D" & f_row) '第1優先
             '.SortFields.Add Key:=sh.Range("G" & s_row & ":" & "G" & f_row) '第2優先
             .SortFields.Add Key:=sh.Range("D" & s_row) '第1優先
             .SortFields.Add Key:=sh.Range("G" & s_row) '第2優先
             .SetRange sh.Range(sh.Cells(s_row, 1), sh.Cells(f_row, lc2)) '範囲
             .Header = xlNo: .Apply
         End With
        '--- 作業列にグループ番号を記述
         sh.Cells(s_row, lc2 + 4) = "第" & i & "グループ"             '●
         sh.Cells(s_row, lc2 + 4).Interior.Color = RGB(255, 204, 204) '●
     Next i

    '------- 作業列に、「A列、D列、G列」のデータを書き込む ----------------------
     With sh
       .Range("A2:A" & fr).Copy .Range(.Cells(2, lc2 + 5), .Cells(fr, lc2 + 5)) '●
       .Range("D2:D" & fr).Copy .Range(.Cells(2, lc2 + 6), .Cells(fr, lc2 + 6)) '●
       .Range("G2:G" & fr).Copy .Range(.Cells(2, lc2 + 7), .Cells(fr, lc2 + 7)) '●
     End With

    '------- グループごとにセル範囲を配列に入れる -------------------------------
     ReDim myRng3(1 To k) As Range
     For i = 1 To k
         s_row = srow(i)
         f_row = frow(i)
         Set myRng3(i) = _
             sh.Range(sh.Cells(s_row, lc2 + 5), sh.Cells(f_row, lc2 + 7))
     Next i

    '------- 重複している削除対象範囲(myRng4)を取得 -----------------------------
     Dim j As Long, x As Long, y As Long, num As Long, z As Long
     Dim Dic As Object, buf As Variant, myRng4 As Range, cnt As Long
     Set Dic = CreateObject("Scripting.Dictionary")

     For i = 1 To k - 1
         If Not Dic.Exists(i) Then '辞書未登録なら(登録されていたら、次のiのForループ)
            num = myRng3(i).Rows.Count * 3  'データ数
            For j = i + 1 To k
                If Not Dic.Exists(j) Then '辞書未登録なら(登録されていたら、次のjのForループ)
                   z = 0 '初期値
                   If myRng3(i).Rows.Count = myRng3(j).Rows.Count Then 'セルの個数が一致したら
                      For y = 1 To 3 '3列分
                          For x = 1 To myRng3(i).Rows.Count '行数分
                              '内容が、1つ一致したらカウント(zに1を加算)
                               If myRng3(i).Cells(x, y) = myRng3(j).Cells(x, y) Then z = z + 1
                          Next x
                      Next y
                   End If
                   '**********************************************************************************
                   If z = num Then '内容が、全一致なら
                      buf = j
                      If Not Dic.Exists(buf) Then
                         Dic.Add buf, buf '辞書に登録されていなけば登録(重複したグループ番号を登録)
                      End If
                      s_row = srow(j)
                      f_row = frow(j)
                      cnt = cnt + 1 '重複数をカウント
                      sh.Range(sh.Cells(s_row, lc2 + 5), sh.Cells(f_row, lc2 + 7)).Interior.Color = _
                               RGB(255, 0, 0) '●重複している箇所を赤く塗りつぶす(作業列)
                      If myRng4 Is Nothing Then
                         Set myRng4 = sh.Range(s_row & ":" & f_row)
                      Else
                         Set myRng4 = Union(myRng4, sh.Range(s_row & ":" & f_row))
                      End If
                   End If
                  '**********************************************************************************
                End If
            Next j
         End If
     Next i

     sh.Range(Columns(1), Columns(lc2 + 7)).AutoFit '列幅自動調整

    '------- A列に品名を記述(グループのトップ位置のみに記述)------------------
    'r-1は、貼り付け最終行
     Set myRng = sh.Range(sh.Cells(3, "A"), sh.Cells(r - 1, "A"))

     If Not myRng Is Nothing Then myRng.ClearContents '品名を削除
     For Each c In myRng
         If sh.Cells(c.Row, lc2 + 4).Value <> "" Then
           c = sh.Cells(c.Row, lc2 + 5).Value '品名の必要文字を記述
        End If
     Next c

    '------- 「Log」シートを作成 ------------------------------------------------
     sh.Copy after:=Worksheets(Worksheets.Count)
     Sheets(Worksheets.Count).Name = "Log"
     newbk.Sheets("Log").Range(Columns(1), Columns(lc2 + 1)).Delete
     If cnt = 0 Then
        msg = "重複はありませんでした"
     Else
        msg = "重複が、" & cnt & "件ありました"
     End If
     newbk.Sheets("Log").Range("A1") = msg

    '------- 重複している削除対象範囲(myRng4)と「作業列」を削除 -----------------
     If Not myRng4 Is Nothing Then myRng4.Delete
     sh.Activate
     sh.Range(Columns(lc2 + 2), Columns(lc2 + 7)).Delete

    '------- 指定した列の列幅をゼロにする ---------------------------------------
     'sh.Range(zc).ColumnWidth = 0

    '------- 出力ファイルの保存 -------------------------------------------------
     Dim fname2 As String, bk_name As String
     fname2 = fname & Format(Date1, "yyyymmdd") & ".xlsx"
     Call ファイル保存(newbk, fname2, bk_name) '★

    '------- 後処理 -------------------------------------------------------------
     Application.ScreenUpdating = True

     title = " 処理が終了しました"
     msg = msg & vbCrLf & vbCrLf & "出力先" & vbCr & bk_name
     MsgBox msg, vbOKOnly, title

     Set newbk = Nothing
     Set sh = Nothing
     Set myRng = Nothing
     Set myRng2 = Nothing
     For i = 1 To k
         Set myRng3(i) = Nothing
     Next i
     Set myRng4 = Nothing
     Set Dic = Nothing
 End Sub

 Private Sub 品名チェック(ByVal sh As Worksheet, ByVal sr As Long, _
                          ByVal fr As Long, ByVal lc2 As Long, _
                          ByVal newbk As Workbook)

     Dim myRng As Range, c As Range
     Set myRng = sh.Range(sh.Cells(sr, "A"), sh.Cells(fr, "A")) 'A列sr行目〜

     Dim flag2 As Boolean
     Dim msg As String, title As String
     Dim sheet_name As String
     Dim cell_add As String

     For Each c In myRng
        '--- 品名(A列)が、グループのトップ位置に入力されてなければTrue
         flag2 = False 'リセット
         If c.Row = sr And c = "" Then
            flag2 = True
         ElseIf c.Offset(-1, 0) = "" And c.Offset(-1, 3) = "" And _
                c.Offset(0, 3) <> "" Then
                If c = "" Then flag2 = True
         End If

        '--- flagがTrueならMsgBoxを表示して、新規ブックを保存せず終了
         If flag2 = True Then
            title = " 終了します"
            sheet_name = sh.Cells(c.Row, lc2 + 2)
            cell_add = "A" & sh.Cells(c.Row, lc2 + 3)
            msg = "品名が、グループのトップ位置に入力されていません" & _
                   vbCrLf & vbCrLf & "「" & sheet_name & _
                   "」シートの「" & cell_add & "」セルを確認してください"
            ThisWorkbook.Sheets(sheet_name).Activate
            ThisWorkbook.Sheets(sheet_name).Range("" & cell_add & "").Select
            Application.ScreenUpdating = True
            MsgBox msg, vbOKOnly, title
            newbk.Close SaveChanges:=False
            Application.ScreenUpdating = True: End
         End If
     Next c
 End Sub

 Private Sub ファイル保存(ByVal newbk As Workbook, ByVal filename As String, _
                          ByRef bk_name As String)

     Dim msg As String, title As String, rc As String
     Dim wb As Workbook
     bk_name = CreateObject("WScript.Shell").SpecialFolders("DeskTop") & _
               "\" & filename 'デスクトップをファイルの保存先に設定

     If Dir(bk_name) <> "" Then 'すでにファイルが存在していたら
        msg = "上書きしますか?" & vbCr & vbCr & bk_name
        title = " 既に同名のファイルが、あります"
        rc = MsgBox(msg, vbYesNo, title)
        If rc = vbNo Then
           Application.ScreenUpdating = True
           MsgBox "終了します": newbk.Close SaveChanges:=False
           Application.ScreenUpdating = True: End
        End If
     End If

     Application.DisplayAlerts = False
         For Each wb In Workbooks
             If wb.Name = filename Then 'ファイルが開いていたら閉じる
                Workbooks(filename).Close: Exit For
             End If
         Next wb
         newbk.SaveAs filename:=bk_name '名前を付けてファイルを保存
        'newbk.Close '◆ファイルを閉じたい場合は、先頭の「'」を削除
     Application.DisplayAlerts = True
 End Sub
 '***** ↑sample5のコードは、ここまで ****************************
 '_
 '_
 ■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■ 
 '***** ↓商品名の並び替えのコードは、ここから ******************
 Option Explicit

 Const fname As String = "商品一覧_"  '☆出力ファイルのファイル名(前半部分)
 Const sname As String = "一覧"       '☆出力ファイルのシート名

 Const lc As String = "BL"       '☆取得元シートの取り扱い最終列

 Sub 商品名の並び替え()
     Dim wb As Workbook, cnt As Long
     Dim newbk As Workbook

    '------- 商品一覧_yyyymmdd.xlsxファイルが1つだけ開かれているか確認する -----
     For Each wb In Workbooks
         If Left(wb.Name, Len(fname)) = fname And _
            Right(wb.Name, 4) = "xlsx" And _
            wb.Name <> ThisWorkbook.Name Then
            cnt = cnt + 1: Set newbk = wb
         End If
     Next wb
     Dim msg As String, title As String

     If cnt > 1 Then
        msg = "「 " & fname & "yyyymmdd.xlsx 」" & vbCrLf & _
              "形式のファイルが、複数開いています" & vbCrLf & _
              "開いているファイルを1つだけにしてください"
     ElseIf cnt = 0 Then
        msg = "「 " & fname & "yyyymmdd.xlsx 」" & vbCrLf & _
              "形式のファイルを1つ開いてい下さい"
     End If

     If cnt > 1 Or cnt = 0 Then
        title = " 終了します"
        MsgBox msg, vbOKOnly, title
        End '終了する
     End If

    '------- 一覧シートのA列の左箇所に4列挿入 ---------------------
     Dim sh As Worksheet
     Set sh = newbk.Sheets(sname) '開いたファイルの「一覧」シート
     Dim fr As Long
     fr = sh.Cells(Rows.Count, "D").End(xlUp).Row 'D列最終行を取得
     sh.Activate 'アクティブにする
     sh.Columns("A:D").Insert 'A列の左に列を挿入
     Dim myRng As Range, c As Range
     Set myRng = sh.Range(sh.Cells(3, "E"), sh.Cells(fr, "E"))

    '------- A,B,C列(作業列)に値を入れる -------------------------
     Dim r1 As Long
     For Each c In myRng
        If c <> "" Then
           c.Offset(0, -4) = c               'A列
           r1 = c.Row
           c.Offset(0, -3) = r1            'B列
        Else
           c.Offset(0, -4) = c.Offset(-1, -4) 'A列
           c.Offset(0, -3) = r1
        End If
     Next

     Set myRng = sh.Range(sh.Cells(4, "E"), sh.Cells(fr + 1, "E"))
     For Each c In myRng
        If c <> "" Then
           c.Offset(-1, -2) = c.Row - 1
        ElseIf c.Row = fr + 1 Then
           c.Offset(-1, -2) = c.Row - 1
        End If
     Next

     Dim i As Long, x As Long
     x = sh.Range("C" & fr)
     For i = fr - 1 To 3 Step -1
         If sh.Range("C" & i) = "" Then
            sh.Range("C" & i) = x
         Else
            x = sh.Range("C" & i)
         End If
     Next i

    '------- A,B,C列(作業列)の文字列を★で繋げて、D列(作業列)に値を入れる -----
     Set myRng = sh.Range(sh.Cells(3, "D"), sh.Cells(fr, "D"))
     Dim str1 As String, str2 As String, str3 As String
     str3 = WorksheetFunction.Rept(0, Len(Trim(fr))) '表示形式:frが3桁なら「000」
     For Each c In myRng
         str1 = Format(c.Offset(0, -2), str3)
         str2 = Format(c.Offset(0, -1), str3)
         c = c.Offset(0, -3) & "★" & str1 & "★" & str2
     Next

    '------- 並び替え -----------------------------------------------------
     Dim lc2 As Long
     lc2 = sh.Range(lc & "1").Column '列のアルファベットを列番号に変換
     lc2 = lc2 + 4 '4列挿入したので、最終列が4ずれる

     sh.Sort.SortFields.Clear '並べ替え条件をクリア(リセットする)

    '****************************************************************
     With sh.Sort

        '.SortFields.Add Key:=sh.Range("D3:D" & fr), _
          SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal '第1優先

         .SortFields.Add Key:=sh.Range("D3") '第1優先

         .SetRange sh.Range(sh.Cells(3, 1), sh.Cells(fr, lc2)) '範囲
         '.MatchCase = False
         '.Orientation = xlTopToBottom
         '.SortMethod = xlPinYin 'ふりがなを使って並べ替え(規定値)
         '.SortMethod = xlStroke 'ふりがなを使わずに並べ替え
         .Header = xlNo
         .Apply
     End With
    '*****************************************************************

     sh.Columns("A:D").Delete '★作業列を削除

     MsgBox "商品名をあいうえお順に、並び替えました", vbOKOnly, newbk.Name

     Set newbk = Nothing: Set sh = Nothing: Set myRng = Nothing
 End Sub
  '***** ↑商品名の並び替えのコードは、ここまで *****************

(マリオ) 2017/02/24(金) 22:24


 >たいよう さん

 検証してみて、問題なさそうでしょうか?最終形のファイルを一時的に置いておきます(2017/2/26 13:43)
 後で削除します。

 〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓
http://d.kuku.lu/46c702e85f
 〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓

 ■重複しないリストを作成_商品グループ_5.zip

(マリオ) 2017/02/24(金) 22:31


 >たいよう さん

 たいようさんの「Sub test3()」で得られる結果
 と
 こちらの「Sample5」及び、「Sub 商品名の並び替え()」で得られる結果
 は、一致してました。(ただし、見出しを除いたデータ部分)

 全75グループのうち、重複が20ですね。

 *****************************************
 >ウッシさん

 stopがあるところら辺を修正したいのですよね。

 ウッシさんと同様に、私の環境(Windows10 64bit , Excel2013 32bit)
 でも、現状のtest_4で、
 「ごはん」と「小型コッペパン」が重複削除されず、
 1グループずつ残ってしまいますね。
(マリオ) 2017/02/24(金) 23:37

ウッシさんのtest_4をざっと拝見しました。
フィルタオプションの処理の中で、
商品、数量等の見出しが二カ所に登場することが
結果に影響していないでしょうか。
# 確たる根拠があって申し上げているわけではないです。

(γ) 2017/02/25(土) 11:10


 > たいよう さん

 ■■■■■■■■■■■■■■■■■■■■■■■■
 Call 品名チェック(sh, sr, fr, lc2, newbk) '★
 ■■■■■■■■■■■■■■■■■■■■■■■■
 での処理について

 たいよう さんが、アップロードされたファイルの
 「8」シートのA3セルの「文字列」を削除してから、
 Sample5を実行してみてください。

 「8」シートのA3に、品名が記述されてないことを
 警告してくれます。

 *****************************
 同様に、「8」シートのA7セルの「文字列」を削除して、
 「8」シートのA8セルに、その「文字列」を記述してから、
 Sample5を実行してみてください。警告されます。

 *****************************
 なお、「8」シートのA5セルの「文字列」を削除した場合は、
 「8」シートのA3セルのグループと認識されちゃいます。

 ★この記事は、既に削除された、
 たいよう さんがアップロードされたファイル
 に関してのことなので、後で削除します
(マリオ) 2017/02/25(土) 12:31


 >たいよう さん

 出力ファイルで、指定した列だけ、列幅をゼロにしたいなら、

 Smaple5のコードの次のConstの定数を変更した後に、
 *****************************************************************
 Const zc As String = "K:K,L:L,O:R,U:U,X:AA,AC:AE,AH:AL,AN:AS,AW:BH,BJ:BL" '☆列幅をゼロにしたい列
 *****************************************************************

 次のコードの先頭の「'」を削除してください。
     'sh.Range(zc).ColumnWidth = 0
(マリオ) 2017/02/26(日) 13:50

こんにちは、γさん

コメント有難うございます。

ただ、フィルタオプションを実行している作業用シートでは

セルA1が商品名、D1が数量、G1が数量で、それ以外には重複してセットされた項目名は

有りませんので、原因は別にあるかと思います。

(ウッシ) 2017/02/27(月) 08:26


こんにちは

原因は不明なのですが、フィルターオプションでも出来るようにコード修正しました。

Option Explicit

Sub test_5()

    Dim aBk As Workbook
    Dim tSh As Worksheet
    Dim pSh As Worksheet
    Dim uBk As Workbook
    Dim uSh As Worksheet
    Dim vSh As Worksheet
    Dim r   As Range
    Dim t   As Range
    Dim h   As Long
    Dim i   As Long
    Dim j   As Long
    Dim a() As Variant

    Application.ScreenUpdating = False
    Set aBk = ThisWorkbook
    Set uBk = Workbooks.Add
    Set uSh = uBk.Worksheets(1)
    uSh.Name = "一覧"
    Set vSh = uBk.Worksheets.Add
    Set tSh = uBk.Worksheets.Add

    With tSh
        .Range("A1:BL1").Formula = "=""dummy""&COLUMN(A1)"
        .Range("A1:BL1").Value = .Range("A1:BL1").Value
        .Range("A1").Value = "商品名"
        .Range("D1").Value = "部品"
        .Range("G1").Value = "数量"
        .Range("BM1").Value = "グループ"
        .Range("BN1").Value = "部品グループ"

        For h = 2 To aBk.Worksheets.Count - 6
            Set pSh = aBk.Worksheets(h)
            pSh.Range("A3:BL42").Copy
            .Range("D" & Rows.Count).End(xlUp).Offset(1, -3).PasteSpecial xlPasteValues
        Next
        .Range("A:A").Copy .Range("BO1")
        .Range("D:D").Copy .Range("BP1")
        .Range("G:G").Copy .Range("BQ1")

        .Range("H:BL").ColumnWidth = 0.27

        With .Range("BM2:BM" & .Range("D" & Rows.Count).End(xlUp).Row)
            .Formula = "=IF(A2<>"""",ROW(A1),IF(D2="""","""",BM1))"
            .Offset(, 1).Formula = "=IF(A2<>"""",A2&TEXT(ROW(A1),""000000""),IF(D2="""","""",BN1))"
            .Resize(, 2).Value = .Resize(, 2).Value
        End With

        .Sort.SortFields.Clear
        .Sort.SortFields.Add Key:=.Range("BN:BN" _
            ), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .Sort.SortFields.Add Key:=.Range("BO:BO" _
            ), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
        .Sort.SortFields.Add Key:=.Range("BP:BP" _
            ), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .Sort.SortFields.Add Key:=.Range("BQ:BQ" _
            ), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        With .Sort
            .SetRange tSh.Range("A:BQ")
            .Header = xlYes
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With

        .Sort.SortFields.Clear
        .Sort.SortFields.Add Key:=.Range("BN:BN" _
            ), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .Sort.SortFields.Add Key:=.Range("BP:BP" _
            ), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .Sort.SortFields.Add Key:=.Range("BQ:BQ" _
            ), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        With .Sort
            .SetRange tSh.Range("B:BQ")
            .Header = xlYes
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
        .Range("A:A").Copy .Range("BO1")
        .UsedRange.Copy vSh.Range("A1")
        .Activate

        For Each r In .Range("BO2", .Range("BM" & Rows.Count).End(xlUp).Offset(, 2))
            If r.Value <> "" Then
                Set t = r.End(xlToRight).Offset(, 1)
                t.Select
            Else
                t.Resize(, 2).Value = r.Offset(, 1).Resize(, 2).Value
                Set t = t.End(xlToRight).Offset(, 1)
                t.Select
                r.EntireRow.ClearContents
            End If
        Next

        .UsedRange.Sort _
            Key1:=.Range("BO1"), Order1:=xlAscending, _
            Header:=xlYes

        .Columns("BN:BN").Delete

        With .Range("BN1").Resize(, _
                    .UsedRange.Columns.Count - .Range("BM1").Column)
            .Formula = "=""ddd""&COLUMN(A1)"
            .Value = .Value
        End With

        uSh.Range("A1:BL1").Value = .Range("A1:BL1").Value

        .Range("A:BL").Delete

        .Range("B1").Resize( _
            .Range("A" & Rows.Count).End(xlUp).Row, _
            .Range("A1").CurrentRegion.Columns.Count - 1).AdvancedFilter _
            Action:=xlFilterInPlace, Unique:=True

        .Range("A:A").SpecialCells(xlCellTypeVisible).Copy vSh.Range("BS1")

        vSh.Range("A1").CurrentRegion.AdvancedFilter _
            Action:=xlFilterCopy, _
            CriteriaRange:=vSh.Range("BS1").CurrentRegion, _
            CopyToRange:=uSh.Range("A1:BL1"), Unique:=False

        Application.DisplayAlerts = False
        .Delete
        vSh.Delete
        Application.DisplayAlerts = True
    End With

    uSh.Range("A1:BL1").Value = aBk.Worksheets(2).Range("A2:BL2").Value

    uBk.SaveAs filename:=CreateObject("WScript.Shell").SpecialFolders("Desktop") & _
        "\商品一覧_" & Format(Now(), "yyyymmdd hhmmss") & ".xlsx", _
        FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False

    uBk.Close

    Application.ScreenUpdating = True

End Sub

何故か、重複が無視されない行が有りました。
データを入れ替えて試してもその行範囲のデータが重複して残ってしまったので、
不要な列は削除してからフィルタを掛けるように変更しました。

(ウッシ) 2017/02/27(月) 11:21


皆さま、本当にありがとうございます!
検証する時間がなかなかとれず、返信も遅れてしまい申し訳ないです。

コードの書き方、アルゴリズム、フィルターの仕様などなど
皆様のコードを見て、これから学んでいきたいと思います。
また不明な点は相談させていただきたいと思います。よろしくお願いします。

言葉が少なく、しっかりと伝えきれていないままにコードを作成していただいて
本当にありがとうございます!!

(たいよう) 2017/02/27(月) 18:57


コメント返信:

[ 一覧(最新更新順) ]


YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki. Modified by kazu.