[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『別シートから重複する項目の多い順に抽出』（KAKU）
シート1
・・・R・・・・AN・・・・・CA・・・ 1・・・ｱ・・・・50・・・・・64・・・ 2・・・ｶ・・・・30・・・・・74・・・ 3・・・ｻ・・・・20・・・・・84・・・ 4・・・ﾀ・・・・20・・・・・34・・・ 5・・・ｱ・・・・30・・・・・63・・・ 6・・・ｻ・・・・40・・・・・83・・・ 7・・・ｻ・・・・50・・・・・72・・・
これを
シート2に
A・・・E・・・・F G H
1 ｻ・・・110・・・84 83 72
2 ｱ・・・80・・・ 64 63
3 ｶ・・・30・・・ 74
4 ﾀ・・・20・・・ 34
と抽出したいのです。
シート2のA列は
シート1のR列で重複する文字を纏め
シート2のE列は
シート1のR列の重複する文字のANの項目の合計値
シート2のF〜H列は
シート1のR列のCA列の大きい値から順番に抽出
更に
シート2のA列は
シート2のE列の大きい値から順番に
同和であればシート1の現れた順で構いません。
この場合の
シート2の
A1、E1、F1、G1、H1の関数を教えて頂けますでしょうか。
＜ 使用 Excel：Excel2010、使用 OS：Windows10 ＞
シート1
・・・R・・・・AN・・・・・CA・・・ 1・・・ｱ・・・・50・・・・・64・・・ 2・・・ｶ・・・・30・・・・・74・・・ 3・・・ｻ・・・・20・・・・・84・・・ 4・・・ﾀ・・・・20・・・・・34・・・ 5・・・ｱ・・・・30・・・・・63・・・ 6・・・ｻ・・・・40・・・・・83・・・ 7・・・ｻ・・・・50・・・・・72・・・
これを
シート2に
A・・・ E・・・・F・・・ G・・・ H
1 ｻ・・・110・・・84・・・83・・ 72
2 ｱ・・・80・・・ 64・・・63
3 ｶ・・・30・・・ 74
4 ﾀ・・・20・・・ 34
と抽出したいのです。
シート2のA列は
シート1のR列で重複する文字を纏め
シート2のE列は
シート1のR列の重複する文字のANの項目の合計値
シート2のF〜H列は
シート1のR列のCA列の大きい値から順番に抽出
更に
シート2のA列は
シート2のE列の大きい値から順番に
同和であればシート1の現れた順で構いません。
この場合の
シート2の
A1、E1、F1、G1、H1の関数を教えて頂けますでしょうか。
（KAKU） 2019/06/05(水) 17:36
シート1で件数は最大何件になるのだろうか？ （ねむねむ） 2019/06/05(水) 17:39
AN列は整数だけだとして（小数はないものとして） 作業列を使ってもいいのなら
Sheet1は ↓ の配置で説明します
R S T U 1 ア 50 64 80.5 2 カ 30 74 30.33333333 3 サ 20 84 110.25 4 タ 20 34 20.2 5 ア 30 63 6 サ 40 83 7 サ 50 72 8
S列 → AN列 T列 → CA列 U列 → 作業列
U1 =IF(R1="","",IF(COUNTIF($R$1:R1,R1)=1,SUMIF(R:R,R1,S:S)+1/ROW(A2),"")) 下コピー
Sheet1は1行目から100行目までだとして（本当にいきなり1行目から始まってるんですかね？）
Sheet2 A1 =IFERROR(INDEX(Sheet1!$R$1:$R$100,MATCH(LARGE(Sheet1!$U$1:$U$100,ROW(A1)),Sheet1!$U$1:$U$100,0)),"")
E1 =IF(A1="","",SUMIF(Sheet1!$R$1:$R$100,A1,Sheet1!$S$1:$S$100))
A1とE1を下コピー
F1 =IF($A1="","",IFERROR(LARGE(IF(Sheet1!$R$1:$R$100=$A1,Sheet1!$T$1:$T$100),COLUMN(A1)),""))
F1は Ctrl＋Shift＋Enter で確定し、右と下にコピー
提示のサンプルデータでしか試してません。
ところで ↓ 同じ人？ [[20190602094438]]『シート1で重複する文字列の値をシート2に拾い出す』（saku）
参考まで （笑） 2019/06/05(水) 21:13
Option Explicit
Sub test()
Dim wsS As Worksheet, wsD As Worksheet
Dim wsT As Worksheet
Dim dic As Object, k
Dim c As Range, s As String
Dim n As Long
Set wsS = Worksheets("Sheet1")
Set wsD = Worksheets("Sheet2")
With wsD.UsedRange
.Offset(, 4).ClearContents
.Columns(1).ClearContents
End With
Set dic = CreateObject("scripting.dictionary")
For Each c In wsS.Columns("E").SpecialCells(xlCellTypeConstants)
s = c.Value
If Not dic.exists(s) Then
Set dic(s) = CreateObject("system.collections.arraylist")
dic(s).Add 0
End If
dic(s)(0) = dic(s)(0) + c.EntireRow.Columns("R").Value
dic(s).Add c.EntireRow.Columns("CA").Value
Next
Set wsT = Worksheets.Add
For Each k In dic.keys
n = n + 1
wsT.Cells(n, 1).Value = k
wsT.Cells(n, 2).Value = dic(k)(0)
dic(k).removeat 0
dic(k).Sort
dic(k).Reverse
wsT.Cells(n, 3).Resize(, dic(k).Count).Value = dic(k).toarray
Next
With wsT.Cells(1).CurrentRegion
.Sort .Cells(2), xlDescending
wsD.Columns(1).Resize(n).Value = .Columns(1).Value
wsD.Columns(5).Resize(n, .Columns.Count).Value = .Offset(, 1).Value
End With
Application.DisplayAlerts = False
wsT.Delete
Application.DisplayAlerts = True
End Sub
（マナ） 2019/06/06(木) 20:46
VBA 作業シート無しで
Sub test()
Dim a, e, x, y, i As Long, ii As Long, temp, dic As Object
Set dic = CreateObject("Scripting.Dictionary")
With Sheets("sheet1")
With .Range("r1", .Range("r" & .Rows.Count).End(xlUp)).Resize(, 62)
a = Application.Index(.Value, Evaluate("row(1:" & .Rows.Count & ")"), Array(1, 23, 62))
End With
End With
For i = 1 To UBound(a, 1)
If Not dic.exists(a(i, 1)) Then
dic(a(i, 1)) = Array(0, CreateObject("System.Collections.ArrayList"))
End If
dic(a(i, 1))(1).Add a(i, 3)
dic(a(i, 1)) = Array(dic(a(i, 1))(0) + a(i, 2), dic(a(i, 1))(1))
Next
x = dic.keys: y = dic.items
For i = 0 To UBound(x) - 1
For ii = i + 1 To UBound(x)
If y(i)(0) < y(ii)(0) Then
temp = x(i): x(i) = x(ii): x(ii) = temp
temp = y(i): y(i) = y(ii): y(ii) = temp
End If
Next
Next
With Sheets("sheet2")
Intersect(.UsedRange, .Range("a:a,e:h")).ClearContents
For i = 0 To UBound(x)
.Cells(i + 1, 1) = x(i)
.Cells(i + 1, "e") = y(i)(0)
y(i)(1).Sort: y(i)(1).Reverse
.Cells(i + 1, "f").Resize(, y(i)(1).Count) = y(i)(1).ToArray
Next
End With
End Sub
（seiya） 2019/06/06(木) 21:36
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.