こんにちは
テストブックで、
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
とか、色々。
1行目にタイトル行,2行目からデータとして
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において何行目からリストが始まっているのかという事や、シート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
お礼
質問後、素早いご回答ありがとうございました。 まだまだ未熟で、VBAの内容を全て理解出来ていませんが、コピペのみで理想的なレイアウトになり感動しております。 これから、いただきましたアドバス(VBA)を参考にして勉強して参ります。