Excelのマクロについて質問です。 下記のデータを、自動で重複者を省いたうえで、新規会社が増えるたび右側に列が増えるようにしたいです。別sheetに出力されるとなお有難いです。
Excelのマクロについて質問です。 下記のデータを、自動で重複者を省いたうえで、新規会社が増えるたび右側に列が増えるようにしたいです。別sheetに出力されるとなお有難いです。 担当者や会社は適宜増えていきます。 担当者住所・担当者電話・担当者氏名・会社名 担当者住所A・担当者電話A・担当者A・会社A 担当者住所A・担当者電話A・担当者A・会社B 担当者住所B・担当者電話B・担当者B・会社B 担当者住所C・担当者電話C・担当者C・会社A 担当者住所C・担当者電話C・担当者C・会社C 担当者住所E・担当者電話E・担当者E・会社E ・ ・ ・ 【変更後】 担当者住所 ・担当者電話・担当者氏名・会社A・会社B・会社C・会社E・・・ 担当者住所A・担当者電話A・担当者A ・会社A・会社B 担当者住所B・担当者電話B・担当者B ・会社B 担当者住所C・担当者電話C・担当者C ・会社A 担当者住所C・担当者電話C・担当者C ・会社C 担当者住所E・担当者電話E・担当者E ・会社E ・ ・ ・ 説明が下手で申し訳ありません。マクロで良い方法などないでしょうか。 みなさまのお知恵をお貸しいただけますと幸いです。
Visual Basic | Excel・96閲覧
ベストアンサー
変更後にCさんが2行あるのはミスですか？ 新規シートに最初から新規作成する例です。 Sub Sample() Dim i As Long, r As Long, n As Long Dim sh1 As Worksheet, sh2 As Worksheet Dim rng As Range, fnd As Range Set sh1 = ActiveSheet Set sh2 = Sheets.Add(After:=sh1) Application.ScreenUpdating = False sh2.Range("A1:D1").Value = sh1.Range("A1:D1").Value For i = 2 To sh1.Cells(Rows.Count, "A").End(xlUp).Row Set rng = sh1.Cells(i, "C") Set fnd = sh2.Range("C:C").Find(rng.Value, LookAt:=xlWhole) r = sh2.Cells(Rows.Count, "A").End(xlUp).Offset(1).Row If fnd Is Nothing Then sh2.Cells(r, "A").Resize(, 4).Value = sh1.Cells(i, "A").Resize(, 4).Value Else n = sh2.Cells(fnd.Row, Columns.Count).End(xlToLeft).Offset(, 1).Column sh2.Cells(r - 1, n).Value = rng.Offset(, 1).Value sh2.Cells(1, n).Value = "会社名" & n - 3 End If Next i sh2.Columns.AutoFit Application.ScreenUpdating = True sh2.Activate MsgBox "Done." End Sub 既にマクロを1回以上実行していて、そこへ追記というならば「何行目から」をマクロ内で指定しないとですね。 Set sh2 = Sheets("シート名") に変更 For i = ○ To ～ の○を開始行に変更
質問者からのお礼コメント
ありがとうございます！ ミスで記載した部分も考慮してくださり、大変助かりました。 おかげで管理の手間が大幅に削減できます。
お礼日時：1/21 15:18
