| |
▼miyama さん：
>シート２の、s6セルに、企業名を記入したら、
その隣においた図形のボタンに登録した「btn統合_Click」マクロを
実行する例です。
'--------------------------------------- 標準モジュール
Option Explicit
Sub btn統合_Click()
Dim WS1 As Worksheet
Dim WS2 As Worksheet
Dim r As Range
Dim i As Long, k As Long, n As Long
Dim dic As Object
Dim v
Set WS1 = Worksheets("Sheet1")
Set WS2 = Worksheets("Sheet2")
' Sheet1 表範囲にオートフィルタをかけ、必要項目をSheet2に抽出
With WS1.Range("B:B")
Set r = Excel.Range(.Item(1), .Item(.Count).End(xlUp))
End With
WS1.AutoFilterMode = False
r.AutoFilter 1, WS2.Range("S6").Value
If r.SpecialCells(xlVisible).Count > 1 Then
WS2.Range("A1").CurrentRegion.ClearContents
r.Offset(, 1).Resize(, 3).Copy WS2.Range("A1")
End If
r.AutoFilter
'統合
Set dic = CreateObject("Scripting.Dictionary")
With WS2.Range("A1").CurrentRegion
With Intersect(.Cells, .Offset(1))
v = .Value
.ClearContents
For i = 1 To UBound(v)
If Not dic.Exists(v(i, 1)) Then
k = k + 1
dic(v(i, 1)) = k
v(k, 1) = v(i, 1)
v(k, 2) = v(i, 2)
v(k, 3) = v(i, 3)
Else
n = dic(v(i, 1))
v(n, 3) = v(n, 3) + v(i, 3)
End If
Next
.Resize(k).Value = v
End With
.Sort Key1:=.Columns(1), Header:=xlYes
End With
Set dic = Nothing
End Sub
|
|
kanabun
- 10/12/18(土) 0:23 -
