VBAを使用しての重複チェック→住所録作成

質問

VBAを始めたばかりの初心者です。
VBAにて受注データの重複チェックを行い、別シートへ住所録を作りたく奮闘しております。

他のシステムへインポートするため関数を使用するとなぜかエラーが出てしまうのでVBAのみで対応したいです。
Excelはバージョン2016です。

▼受注データはおおむね下記の状態です。

シート1
A　　　　　　B　　　C　　　D　　　E　　F　　G　　　　H　　　I
受注日　　　電話1　電話2　電話3　名前　住所　商品　　数量　　受注ID
2016/2/5　　11　　　111　　1111　山田　東京　りんご　　5　　123-11111
2016/2/5　　11　　　111　　1111　山田　東京　いちご　　2　　123-11111
2016/2/5　　11　　　111　　1111　山田　東京　バナナ　　6　　123-11111
2016/2/5　　80　　　8888　8888　鈴木　福岡　メロン　　1　　123-22222
2016/2/8　　44　　　444　　4444　加藤　奈良　りんご　　3　　123-33333
2016/2/8　　44　　　444　　4444　加藤　奈良　すいか　　1　　123-33333
2016/2/8　　44　　　444　　4444　加藤　奈良　ぶどう　　5　　123-33333
2016/2/8　　44　　　444　　4444　加藤　奈良　レモン　　6　　123-33333
2016/2/8　　44　　　444　　4444　加藤　奈良　いちご　　2　　123-33333

▼やりたいこと
シート2に受注IDを基に重複しないよう抽出して住所録を作りたいです。

(1)　I列で重複をチェック
(2)　B列の電話1ですが先頭にOが削除されて表示されるのでシート2では0を付与してリスト化
(3)　B列～D列の電話番号をシート2のリスト化の際には1つのセルに(ハイフンなしで)まとめる
(4)　(3)とは別のセルにB列～D列の電話番号をハイフンを付与してまとめる
　　※電話番号は固定電話と携帯電話の番号が混ざっています。
(5)　住所録はシート2に作成

補足
(3)の情報は別システムのID(コード)として使用します。
(4)はそのまま電話番号として使用します。

▼理想的な状態

A　　　　　　　B　　　　C　　　　D
ID　　　　　　名前　　　住所　　　電話　
0111111111　　山田　　　東京　　　011-111-1111
08088888888　鈴木　　　福岡　　　080-8888-8888
0444444444　　加藤　　　奈良　　　044-444-4444

▼難しそうなら最悪
A　　　　　　B　　　C　　　D　　　E　　F　　G　　　　H　　　I
受注日　　　電話1　電話2　電話3　名前　住所　商品　　数量　　受注ID
2016/2/5　　11　　　111　　1111　山田　東京　りんご　　5　　123-11111
2016/2/5　　80　　　8888　8888　鈴木　福岡　メロン　　1　　123-22222
2016/2/8　　44　　　444　　4444　加藤　奈良　りんご　　3　　123-33333

までの状態にはもっていきたいです。

Webにて有志のかたの参考情報を基に
受注IDから重複チェックを行い特定のセルのみを抽出することは出来たのですが
行全体を抽出する方法がわかりませんでした…。

よろしくお願いいたします。

回答No.1

ushi2015 · ベストアンサー

こんにちは
テストブックで、
Sub test()
　　Dim t As Range
　　With Worksheets("Sheet2")
　　　　.Cells.Clear
　　　　.Range("A1").Value = "受注ID"
　　　　.Range("B1").Value = "名前"
　　　　.Range("C1").Value = "住所"
　　　　.Range("D1").Value = "電話1"
　　　　.Range("E1").Value = "電話2"
　　　　.Range("F1").Value = "電話3"
　　　　.Range("G1").Value = "電話1"
　　　　With Worksheets("Sheet1")
　　　　　　.Range("A1").CurrentRegion.AdvancedFilter Action:=xlFilterCopy, _
　　　　　　　　CopyToRange:=Worksheets("Sheet2").Range("A1:G1"), Unique:=True
　　　　End With
　　　　Set t = Intersect(.UsedRange.Offset(1), .Range("A1").CurrentRegion)
　　　　With t.Columns(7)
　　　　　　.FormulaR1C1 = "=""0""&RC[-3]&""-""&RC[-2]&""-""&RC[-1]"
　　　　　　.Value = .Value
　　　　End With
　　　　With t.Columns(1)
　　　　　　.FormulaR1C1 = "=""'""&SUBSTITUTE(RC[6],""-"","""")"
　　　　　　.Value = .Value
　　　　End With
　　　　.Range("D:F").Delete
　　　　.Range("A1").Value = "ID"
　　　　.Range("D1").Value = "電話"
　　End With
End Sub
とか、色々。

お礼

質問後、素早いご回答ありがとうございました。
まだまだ未熟で、VBAの内容を全て理解出来ていませんが、コピペのみで理想的なレイアウトになり感動しております。

これから、いただきましたアドバス(VBA)を参考にして勉強して参ります。

回答No.3

keithin

１行目にタイトル行，２行目からデータとして

sub macro1()
　dim w as worksheet
　dim w0 as worksheet
　dim LastRow as long
　set w0 = activesheet
　set w = worksheets.add(after:=w0)

’複製後に重複削除
　w0.range("B:F,I:I").copy destination:=w.range("A1")
　range("A:F").removeduplicates columns:=6, header:=xlyes
　lastrow = cells(rows.count, "F").end(xlup).row

’電話・ID欄の準備
　range("F:F").insert shift:=xlshifttoright
　range("F1") = "電話"
　with range("F2:F" & lastrow)
　　.formula = "=0&A2&""-""&B2&""-""&C2"
　　.value = .value
　end with

　range("D:D").insert shift:=xlshifttoright
　range("D1") = "ID"
　with range("D2:D" & lastrow)
　　.formula = "=0&A2&B2&C2"
　　.numberformat = "@"
　　.value = .value
　end with

’片付け
　range("H:H").clearcontents
　range("A:A").delete shift:=xlshifttoleft
　range("D:D").columns.autofit

end sub

お礼

この度のアドバイスありがとうございます。
1つ1つ、どのような動作のVBAなのかコメントも付けていただき大変分かりやすいアドバイスです。感動しております。

いただきましたアドバイスを基にVBAの意味を確認しながら、精進して参ります。

ありがとうございました。

回答No.2

kagakusuki

シート1において何行目からリストが始まっているのかという事や、シート2において何行目以下にリストを作成すれば良いのか、という事が御質問文中には示されておりませんので、取り敢えず仮の話として、シート1の2行目には「受注日」、「電話1」、「電話2」、「電話3」、「名前」、「住所」、「商品」、「数量」、「受注ID」といった項目名が入力されていて、住所録のリストの中で「ID」、「名前」、「住所」、「電話」等の項目名が入力されているのはシート2の2行目である場合に対応するVBAを回答致します。

Sub QNo9137333_VBAを使用しての重複チェック→住所録作成()

Const DataSheetName = "Sheet1" '元データシートのシート名
Const PasteSheetName = "Sheet2" '抽出先のシートのシート名
Const FirstPasteCell = "A2" '抽出先のリストのセル範囲中における左上の隅のセル
Const ItemRow = 2 '元データシートにおいて「受注日」～「受注ID」等の項目名欄として使用されている行の行番号
Dim DataSheet As Worksheet, PasteSheet As Worksheet, DataColumn As Variant _
, TelColumn As Variant, LastRow As Long, c As Range, i As Long, j As Long
DataColumn = Array("I", "E", "F") 'ID、名前、住所が入力されている列の列番号
TelColumn = Array("B", "C", "D") '電話番号が入力されている列の列番号

If IsError(Evaluate("ROW('" & DataSheetName & "'!A1)")) Then
MsgBox "元データが入力されているシートとして設定されている" _
& vbCrLf & vbCrLf & DataSheetName & vbCrLf & vbCrLf & _
"というシート名のシートが見つかりません。" & vbCrLf _
& "マクロを終了します。", vbExclamation, "存在しないシート"
Exit Sub
End If
Set DataSheet = Sheets(DataSheetName)

LastRow = DataSheet.Range(DataColumn(0) & Rows.Count).End(xlUp).row
If LastRow <= ItemRow Then
MsgBox "処理すべきデータが見当たりませんません。" & vbCrLf _
& "マクロを終了します。", vbExclamation, "データ無し"
Exit Sub
End If

Set TelNo = DataSheet.Range("B" & ItemRow + 1 & ":D" & LastRow)

If IsError(Evaluate("ROW('" & PasteSheetName & "'!A1)")) Then
Set PasteSheet = Worksheets.Add()
PasteSheet.Name = PasteSheetName
Else
Set PasteSheet = Sheets(PasteSheetName)
End If

With Application
.ScreenUpdating = False
.Calculation = xlManual
End With

With DataSheet.Range(DataColumn(0) & ItemRow & ":" & DataColumn(0) & LastRow)
.AdvancedFilter Action:=xlFilterInPlace, Unique:=True
End With

PasteSheet.Range(FirstPasteCell & ":" & PasteSheet.Cells _
.SpecialCells(xlCellTypeLastCell).Address).ClearContents

j = -1
For Each c In DataSheet.Range("A" & ItemRow & ":" _
& "A" & LastRow).SpecialCells(xlCellTypeVisible)
j = j + 1
With PasteSheet.Range(FirstPasteCell)
For i = 0 To UBound(DataColumn)
.Offset(j, i).Value = DataSheet.Cells(c.row, DataColumn(i)).Value
Next i

With .Offset(, UBound(DataColumn) + 1)
If j = 0 Then
.Value = "電話"
Else
For i = 0 To UBound(TelColumn)
.Offset(j).Value = _
.Offset(j).Value & "-" & DataSheet.Range(TelColumn(i) & c.row).Value
Next i
.Offset(j).Value = Mid(.Offset(j).Value, 2)
End If
End With
End With
Next c

DataSheet.ShowAllData

With Application
.Calculation = xlAutomatic
.ScreenUpdating = True
End With

End Sub

お礼

私の質問の仕方などに不備がある中、大変ご丁寧なアドバスをいただきありがとうございました。
MsgBoxの処理なども付けていただいているようで感動しております。

これからいただきましたアドバイスを参考にして、１つづつVBAの意味を理解しながら勉強して参ります。

分かない点がありましたら、またOKWebで質問させていただいます。