| |
▼斉藤 さん：
迷惑かけました。
改訂版です。お試しください。
Transpose 要素数の制限は認識していましたが、要素内の文字の桁数制限は
はじめて認識しました。
勉強になりました。
Sub Sample()
Dim c As Range
Dim dic1 As Object
Dim dic2 As Object
Dim w As Variant
Dim v As Variant
Dim x As Long
Set dic1 = CreateObject("Scripting.Dictionary")
Set dic2 = CreateObject("Scripting.Dictionary")
With Sheets("Sheet1")
For Each c In .Range("A1", .Range("A" & Rows.Count).End(xlUp))
If Not dic1.exists(c.Value) Then
dic1(c.Value) = c.EntireRow.Range("A1:P1").Value
dic2(c.Value) = c.EntireRow.Range("Q1").Value
Else
dic2(c.Value) = dic2(c.Value) & "," & c.EntireRow.Range("Q1").Value
End If
Next
End With
With Sheets("Sheet2")
.Cells.ClearContents
.Range("A1:P1").Resize(dic1.Count).Value = WorksheetFunction.Transpose(WorksheetFunction.Transpose(dic1.items))
w = dic2.items
ReDim v(0 To UBound(w, 1), 1 To 1)
For x = 0 To UBound(w, 1)
v(x, 1) = w(x)
Next
.Range("Q1").Resize(dic2.Count).Value = v
.Select
End With
End Sub
Sub Sample2()
Dim c As Range
Dim dic As Object
Dim v As Variant
Dim w As Variant
Dim x As Long
Set dic = CreateObject("Scripting.Dictionary")
With Sheets("Sheet1")
v = .Range("A1").CurrentRegion.Columns("A:P").Value
For Each c In .Range("A1", .Range("A" & Rows.Count).End(xlUp))
If Not dic.exists(c.Value) Then
dic(c.Value) = c.EntireRow.Range("Q1").Value
Else
dic(c.Value) = dic(c.Value) & "," & c.EntireRow.Range("Q1").Value
End If
Next
End With
With Sheets("Sheet2")
.Cells.ClearContents
.Range("A1").Resize(UBound(v, 1), UBound(v, 2)).Value = v
.Columns("A:P").RemoveDuplicates Columns:=1, Header:=xlYes
w = dic.items
ReDim v(0 To UBound(w, 1), 1 To 1)
For x = 0 To UBound(w, 1)
v(x, 1) = w(x)
Next
.Range("Q1").Resize(dic.Count).Value = v
.Select
End With
End Sub
Sub Sample3()
Dim c As Range
Dim dic As Object
Dim w As Variant
Dim v As Variant
Dim x As Long
Set dic = CreateObject("Scripting.Dictionary")
With Sheets("Sheet1")
For Each c In .Range("A1", .Range("A" & Rows.Count).End(xlUp))
If Not dic.exists(c.Value) Then
dic(c.Value) = c.EntireRow.Range("Q1").Value
Else
dic(c.Value) = dic(c.Value) & "," & c.EntireRow.Range("Q1").Value
End If
Next
End With
With Sheets("Sheet2")
.Cells.ClearContents
Sheets("Sheet1").Columns("A:P").AdvancedFilter Action:=xlFilterCopy, _
CopyToRange:=.Range("A1"), Unique:=True
w = dic.items
ReDim v(0 To UBound(w, 1), 1 To 1)
For x = 0 To UBound(w, 1)
v(x, 1) = w(x)
Next
.Range("Q1").Resize(dic.Count).Value = v
.Select
End With
End Sub
|
|
![[未読]](./data/excel/image/read_icon.gif){kind=icon}
- 16/12/16(金) 22:12 -
