Results of 1 - 1 of about 44 for セルの幅 単位 (0.006 sec.)
セルの幅 (324), 単位 (3439)
- [[20170216155002]]
- #score: 9649
- @digest: 1b8574068278c0a4a674128348583383
- @id: 72714
- @mdate: 2017-02-27T09:57:00Z
- @size: 92874
- @type: text/plain
- #keywords: 〓〓 (164988), 話| (109272), sortfields (57710), dataoption (51272), xlsortonvalues (47422), sorton (36658), xlsortnormal (35648), マリ (34917), 部品 (34854), リオ (28066), 電話 (23905), xlascending (22008), グル (20971), 力フ (17426), ウッ (16448), range (15284), order (14796), sort (14291), 品名 (14004), 数量 (11640), ッシ (11170), 備考 (10813), ープ (10463), 合セ (9592), ルー (9538), 商品 (9366), 重複 (9313), 2017 (9018), usedrange (8005), myrng (7448), シー (6856), sh (6614)
- 『グループ化と比較』（たいよう）
お世話になっております。 商品の内容を比較し、重複しないように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... - http://www.excel.studio-kazu.jp/wiki/kazuwiki/201702/20170216155002.txt - [detail] - similar
PREV
NEXT
Powered by Hyper Estraier 1.4.13, with 97023 documents and 608156 words.
訪問者：