[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『数値と名前の抽出』（もののけ姫）
こんばんわ。 皆様にご指導していただきたく、書き込みします。
今回、HPにExcelを直リンクするか、他の方法で掲示するか悩んでいます。
どのようなものを貼り付けるかといいますと、
[sheet1]もしくは[book1] a b c d e 1 千代田地区 2 Aさん Fさん Cさん Bさん Tさん 3 4 新宿地区 5 Fさん Zさん Hさん Kさん 6 7 渋谷地区 8 Xさん Yさん Iさん 9
このような地区別リストがあります。 50音はばらばらで追加されたら記入するようになっています。 ※横一列だけとは限らず、増員したら下に追加されたりします。
[sheet2]もしくは[book2]
a b c 1 売上実績 金額 名前 2 1位 8577500 Fさん 3 2位 7468960 Aさん 4 3位 7376910 Zさん 5 4位 6840960 Cさん 6 5位 6518300 Xさん 7 6位 5097600 Iさん 8 7位 4719460 Yさん 9 8位 4578690 Bさん 10 9位 3976000 Kさん 11 10位 3587850 Tさん 12 11位 3397650 Hさん
このように、金額の高い順に並んでいます。
この情報を元に、[sheet1]もしくは[book1]の2行目または5行目、8行目の並び替えをしていきたいのですが、可能でしょうか？
たとえば、2行目だと AさんよりFさんが金額が高いので、順番では 千代田地区では Fさん Aさん Cさん Bさん Tさん と並び替えしたいのです。
5行目では、 F>Z>K>H など..
範囲を[sheet1]もしくは[book1]のA2〜E3内で、[sheet2]もしくは[book2]のB2〜C∞から抽出するようにしたいのですが、どうか教えていただけないでしょうか。
ユーザ設定や名前ボックスを利用してみましたが、失敗でした。 並び替えも行指定は難しいですか？ フォーマットを変更してできるものであれば、書き換えます。
マクロの例ですが、下記の用でどうでしょうか。 Sheet2 の名前は降順にソートされていることを前提にしています。
Sub main()
sortByRank Worksheets("Sheet1").Range("A2:E3"), Worksheets("Sheet2").Range("C2:C12")
End Sub
Sub sortByRank(dataRange As Range, rankRange As Range)
Dim tmpWS As Worksheet
Set tmpWS = Worksheets.Add(after:=Worksheets(Worksheets.Count))
Dim r As Range, f As Range
Dim i As Long
i = 1
For Each r In dataRange
If Not IsEmpty(r) Then
tmpWS.Cells(i, "A") = r.Value
Set f = rankRange.Find(what:=r.Value, lookat:=xlWhole)
If f Is Nothing Then
tmpWS.Cells(i, "B") = Rows.Count
Else
tmpWS.Cells(i, "B") = f.Row
End If
i = i + 1
End If
Next
tmpWS.Columns("A:B").Sort _
key1:=tmpWS.Range("B1"), Order1:=xlAscending, _
key2:=tmpWS.Range("A1"), Order2:=xlAscending
dataRange.Clear
Dim lastRow As Long
lastRow = tmpWS.Range("A" & Rows.Count).End(xlUp).Row
For i = 1 To lastRow
dataRange.Resize(1, 1).Offset(0, i - 1) = tmpWS.Cells(i, "A").Value
Next
Application.DisplayAlerts = False
tmpWS.Delete
Application.DisplayAlerts = True
End Sub
(Mook)
Mookさん
とても素晴らしいマクロありがとうございます！
記録させたところ、a2:e3内で並び替えが見事されていました。
これは、千代田地区での並び替えでよかったですよね？
他の地区も並び替えをするとなると、地区毎でコードを追加していけばいいのでしょうか？
新宿地区では、a5:e6
渋谷地区では、a8:e9
など。
sortByRank Worksheets("Sheet1").Range("A2:E3"), Worksheets("Sheet2").Range("C2:C12")
の("A2:E3")をA2:E9としたら、実行時エラー1004のアプリケーション定義のエラーでデバックされてしまいました（汗）
（もののけ姫）
追加の仕方は、
sortByRank Worksheets("Sheet1").Range("A2:E3"), Worksheets("Sheet2").Range("C2:C12")
sortByRank Worksheets("Sheet1").Range("A5:E6"), Worksheets("Sheet2").Range("C2:C12")
:
とすればよいですが、Range を変えただけでエラーが出るのはよくわからないです。
修正後のコード（変更部分だけ）をコピーしてもらえれば、なにかわかるかもしれません。
(Mook)
こんな方法はどうでしょう？
Sub test()
Dim myAreas As Areas, myArea As Range, a(), i As Long
a = Sheets("sheet2").Range("a1").CurrentRegion.Value
With CreateObject("Scripting.Dictionary")
For i = 2 To UBound(a, 1)
.item(a(i, 3)) = i - 1
Next
Set myAreas = Sheets("sheet1").Columns("a").SpecialCells(2).Areas
If myAreas.Count < 2 Then Exit Sub
For Each myArea In myAreas
If myArea.Rows.Count > 1 Then
With myArea.CurrentRegion
ReDim a(1 To 2, 1 To .Columns.Count)
For i = 1 To .Columns.Count
a(1, i) = .Cells(2, i).Value
If .exists(.Cells(2, i).Value) Then
a(2, i) = .item(.Cells(2, i).Value)
End If
Next
HSortMA a, 1, UBound(a, 2), 2
.Rows(2).Value = a
End With
End If
Next
End With
End Sub
Private Sub HSortMA(ary, LB, UB, ref)
Dim i As Long, ii As Long, iii As Long, M As Variant, temp As Variant
i = UB : ii = LB
M = ary(ref, Int((LB+UB)/2))
Do While ii <= i
Do While ary(ref,ii) < M
ii = ii + 1
Loop
Do While ary(ref,i) > M
i = i - 1
Loop
If ii <= i Then
For iii = LBound(ary,1) To UBound(ary,1)
temp = ary(iii,ii) : ary(iii,ii) = ary(iii,i) : ary(iii,i) = temp
Next
i = i - 1 : ii = ii + 1
End If
Loop
If LB < i Then HSortMA ary, LB, i, ref
If ii < UB Then HSortMA ary, ii, UB, ref
End Sub
(seiya)
Mookさん
a b c d e
−−−−−−−−−−−−−−−−−−−−−−−−−
1 千代田地区 ｜
2 Aさん Fさん Cさん Bさん Tさん｜
3 ｜
4 新宿地区 ｜
5 Fさん Zさん Hさん Kさん ｜
6 ｜
7 渋谷地区 ｜
8 Xさん Yさん Iさん ｜
9
−−−−−−−−−−−−−−−−−−−−−−−−−
sortByRank Worksheets("Sheet1").Range("A1:E9"), Worksheets("Sheet2").Range("C2:C132")
四角の囲んだエリアに書き換えてしまったらエラーがでました。
他の地区で試したところ、例えば 横浜地区 Aさん Fさん Cさん Bさん Tさん Dさん Rさん
といった人数の場合、5人区切りで行を増やしています。
マクロ後、並び替えが一行に設定してあるものを、数行（５人ｘ＊行）で並び替えも可能でしょうか。 Seiyaさん 素晴らしいコードありがとうございます。
If .exists(.Cells(2, i).Value) Then ここでデバックしてしまうのですが definedと同じ関数としてみていいのでしょうか。
自分でも少し編集できるところはがんばってみます。 （もののけ姫）
あーーー、 With statement がかぶっていますね... 下記に変更してください。
Sub test()
Dim myAreas As Areas, myArea As Range, a(), i As Long
Dim dic As Object
Set dic = CreateObject("Scripting.Dictionary")
a = Sheets("sheet2").Range("a1").CurrentRegion.Value
For i = 2 To UBound(a, 1)
dic(a(i, 3)) = i - 1
Next
Set myAreas = Sheets("sheet1").Columns("a").SpecialCells(2).Areas
If myAreas.Count < 2 Then Exit Sub
For Each myArea In myAreas
If myArea.Rows.Count > 1 Then
With myArea.CurrentRegion
ReDim a(1 To 2, 1 To .Columns.Count)
For i = 1 To .Columns.Count
a(1, i) = .Cells(2, i).Value
If dic.exists(.Cells(2, i).Value) Then
a(2, i) = dic(.Cells(2, i).Value)
End If
Next
HSortMA a, 1, UBound(a, 2), 2
.Rows(2).Value = a
End With
End If
Next
End Sub
(seiya)
>マクロ後、並び替えが一行に設定してあるものを、数行（５人ｘ＊行）で並び替えも可能でしょうか。
期待する結果はどのような感じになるのでしょう？ (seiya)
A1:E9 の範囲には「＊＊＊地区」というデータもあるのですよね。 これは想定外の状況です。
並べ替えを行うデータの集合単位で実行すると思っていましたので、先にも書いたように 集合の数だけ、関数の呼び出しが必要になります。
ちなみにエリア内にセルの結合はないでしょうか。 またエラーが出たときは、エラーが出た行とそのときの状況も説明するようにした方が 解決が早いと思います。
データの入出力が5行単位という条件で全体が統一されているのであれば、そのような
対応は可能ですが、地区によってまちまちだとちょっと変更が大きくなりそうです。
5列単位にするなら
dataRange.Resize(1, 1).Offset(0, i - 1) = tmpWS.Cells(i, "A").Value
を
dataRange.Resize(1, 1).Offset(Int((i-1)/5), (i - 1) Mod 5) = tmpWS.Cells(i, "A").Value
にしてみてください。
(Mook)
seiyaさん はい。今フォーマットも見やすいものをと試行錯誤で作成しています。 データの量は、管轄エリアで100くらいを下記のように保存していきたいのですが [sheet1]もしくは[book1] a b c d e ｆ 1 千代田地区 Aさん Fさん Cさん Bさん Tさん 2 新宿地区 Fさん Zさん Hさん 3 渋谷地区 Xさん Kさん Yさん Sさん Iさん 4 Mさん Zさん 5 世田谷地区 Dさん Pさん 6 大田区地区 Tさん Lさん Yさん Wさん ・ ・ ・ このほうがスムーズな気もしますが、 結果は、B1からF6（実際はもっとあります）の中で ５人ずつに分けて記入しているので 渋谷地区のように7人の場合は、B3:F4で並び替え（表示は変わらず5人と2人に）
Zさん Xさん Iさん Yさん Kさん Mさん Sさん と、順位が高い人から並び替えができるようにしたいです。
Mookさんに作っていただいた横一列表示もよいのですが、 中には20人いる地区もありますので横に長くなってしまって目視するのが大変という こともあり、区切らせています。
こんな感じで考えています。
Mookさん 地区もあるので、同じ列にあると条件しにくいですよね・・。 上記のように書きかえて試してみます＾＾
（もののけ姫）
Seiyaさん HSortMAのプロシージャはどうすればよいのでしょうか・・。
HSortMA a, 1, UBound(a, 2), 2 コンパイルエラーで定義を求められました＾＾； （もののけ姫）
> HSortMA a, 1, UBound(a, 2), 2 > コンパイルエラーで定義を求められました＾＾；
エラーメッセージは、正確に書くようにしませんか？ 「Sub または Function が定義されていません」 ですか？
先にseiyaさんが提示されている以下のコードは、記述してありますか？
Private Sub HSortMA(ary, LB, UB, ref) '〜省略〜 End Sub
(とおりすがり)
とおりすがりさん
Sub または Function が定義されていません
です。
コードは記述済みです・・。
Sub test()
Dim myAreas As Areas, myArea As Range, a(), i As Long
a = Sheets("Pointchart").Range("a1").CurrentRegion.Value
With CreateObject("Scripting.Dictionary")
For i = 2 To UBound(a, 1)
.Item(a(i, 3)) = i - 1
Next
Set myAreas = Sheets("WishList").Columns("a").SpecialCells(2).Areas
If myAreas.Count < 2 Then Exit Sub
For Each myArea In myAreas
If myArea.Rows.Count > 1 Then
With myArea.CurrentRegion
ReDim a(1 To 2, 1 To .Columns.Count)
For i = 1 To .Columns.Count
a(1, i) = .Cells(2, i).Value
If .exists(.Cells(2, i).Value) Then
a(2, i) = .Item(.Cells(2, i).Value)
End If
Next
HSortMA a, 1, UBound(a, 2), 2
.Rows(2).Value = a
End With
End If
Next
End With
End Sub
Private Sub HSortMA(ary, LB, UB, ref)
Dim i As Long, ii As Long, iii As Long, M As Variant, temp As Variant
i = UB: ii = LB
M = ary(ref, Int((LB + UB) / 2))
Do While ii <= i
Do While ary(ref, ii) < M
ii = ii + 1
Loop
Do While ary(ref, i) > M
i = i - 1
Loop
If ii <= i Then
For iii = LBound(ary, 1) To UBound(ary, 1)
temp = ary(iii, ii): ary(iii, ii) = ary(iii, i): ary(iii, i) = temp
Next
i = i - 1: ii = ii + 1
End If
Loop
If LB < i Then HSortMA ary, LB, i, ref
If ii < UB Then HSortMA ary, ii, UB, ref
End Sub
こちらのとおりです。 （もののけ姫）
> Sub または Function が定義されていません > です。 > コードは記述済みです・・。
どの行で出ますか？ 提示されたコードですと、別の箇所で、別のエラーメッセージが出ます。
seiyaさんが、 > With statement がかぶっていますね... という誤りに気づかれて、修正されているのですが、もののけ姫さんが先ほど提示されたコードでは、 そのコードになっていません。
再度、ご確認されてはいかがでしょうか？
なお、 > マクロ後、並び替えが一行に設定してあるものを、数行（５人ｘ＊行）で並び替えも可能でしょうか。 の追加要件は、確認していません。
(とおりすがり)
とおりすがりさん
申し訳ありません・・こちらでした。
Sub test()
Dim myAreas As Areas, myArea As Range, a(), i As Long
Dim dic As Object
Set dic = CreateObject("Scripting.Dictionary")
a = Sheets("sheet2").Range("a1").CurrentRegion.Value
For i = 2 To UBound(a, 1)
dic(a(i, 3)) = i - 1
Next
Set myAreas = Sheets("sheet1").Columns("a").SpecialCells(2).Areas
If myAreas.Count < 2 Then Exit Sub
For Each myArea In myAreas
If myArea.Rows.Count > 1 Then
With myArea.CurrentRegion
ReDim a(1 To 2, 1 To .Columns.Count)
For i = 1 To .Columns.Count
a(1, i) = .Cells(2, i).Value
If dic.exists(.Cells(2, i).Value) Then
a(2, i) = dic(.Cells(2, i).Value)
End If
Next
HSortMA a, 1, UBound(a, 2), 2
.Rows(2).Value = a
End With
End If
Next
End Sub
こちらでした・・。しかし、
Next
HSortMA a, 1, UBound(a, 2), 2
.Rows(2).Value = a
の HSortMA 部分でエラーが生じます。
（もののけ姫）
> こちらでした。 > > HSortMA 部分でエラーが生じます。
どういうエラーメッセージですか？ Sub または Function が定義されていません ならば、以下のコードは記述してありますか？とお聞きしているのですが・・・
Private Sub HSortMA(ary, LB, UB, ref) '〜省略〜 End Sub
こちらで以下のようなコードにして、簡単にテストしたら、エラーは出ないようです。
Sub test() '←seiyaさんより差替え提示あり '〜省略〜 End Sub
Private Sub HSortMA(ary, LB, UB, ref) '←seiyaさんの差替え前のコードのまま '〜省略〜 End Sub
(とおりすがり)
とおりすがりさん Private Subのコードが抜けておりました＾＾； 変更したところ、エラーはなくなりました。
ところどころに、 a b c d e ｆ 1 千代田地区 Aさん Fさん Cさん Bさん Tさん 2 Fさん Zさん 新宿地区 Hさん 3 渋谷地区 Xさん Kさん Yさん Sさん Iさん 4 Mさん Zさん 5 世田谷地区 Dさん Pさん 6 大田区地区 Tさん Lさん Yさん Wさん ・ ・ ・ といった、地区列（a列）とB〜F列のものが入れ替わったりしています>.< （もののけ姫）
> 地区列（a列）とB〜F列のものが入れ替わったりしています>.<
最初に提示された以下のサンプルデータでテストしていますが、そのような事象にはなりません。
シート名 WishList a b c d e 1 千代田地区 2 Aさん Fさん Cさん Bさん Tさん 3 4 新宿地区 5 Fさん Zさん Hさん Kさん 6 7 渋谷地区 8 Xさん Yさん Iさん 9
シート名 Pointchart
a b c 1 売上実績 金額 名前 2 1位 8577500 Fさん 3 2位 7468960 Aさん 4 3位 7376910 Zさん 5 4位 6840960 Cさん 6 5位 6518300 Xさん 7 6位 5097600 Iさん 8 7位 4719460 Yさん 9 8位 4578690 Bさん 10 9位 3976000 Kさん 11 10位 3587850 Tさん 12 11位 3397650 Hさん
まずは、この状態で確認されて、次に違うデータで確認してみてはいかがでしょうか？ もし違うデータで、期待している結果にならないなら、サンプルデータを提示しなおしてみるといいかと思います。
(とおりすがり)
素人なので難しいコードはわかりませんが、 Mookさんのコードを使用しようと追加していったのですが 件数が多いため100近くで苦戦しています。
凝縮できるようにデータのほうも単純に作成しようと思います。
そこでなのですが、sinyaさんのコードで
横浜地区 Aさん Xさん Rさん Cさん Nさん Tさん Iさん Fさん Iさん Bさん Bさん Rさん Sさん Rさん Sさん Sさん 川崎地区 Iさん Nさん Nさん Fさん Mさん Bさん Nさん Gさん Cさん Pさん Aさん Sさん Mさん Zさん Zさん Xさん Tさん Sさん
での、並び替えは可能ですか？
現在の 横浜地区 Aさん Xさん Rさん Cさん Nさん Tさん Iさん Fさん Iさん Bさん・・・・・・
川崎地区 Iさん Nさん Nさん Fさん Mさん Bさん Nさん Gさん Cさん Pさん・・・・
を、 横浜地区 Aさん Xさん Rさん Cさん Nさん Tさん Iさん Fさん Iさん Bさん・・・・・・
もしくは、 横浜地区 Aさん Xさん Rさん Cさん Nさん Tさん Iさん Fさん Iさん Bさん Bさん Rさん Sさん Rさん Sさん Sさん 川崎地区 Iさん Nさん Nさん Fさん Mさん Bさん Nさん Gさん Cさん Pさん Aさん Sさん Mさん Zさん Zさん Xさん Tさん Sさん
とした形での並び替えができるようにするには コードの変更は大掛かりになってしまいますか？
（もののけ姫）
> そこでなのですが、sinyaさんのコードで 私のことですか？
可能ですが、これが本来質問したかったことですか？ 最初からこのように質問した方がいいですよ？ 折角回答したコードが無駄になる。
Sub test()
Dim myAreas As Areas, a(), b(), i As Long, ii As Long, n As Long, t As Long
Dim dic As Object
Set dic = CreateObject("Scripting.Dictionary")
a = Sheets("sheet2").Range("a1").CurrentRegion.Value
For i = 2 To UBound(a, 1)
dic(a(i, 3)) = i - 1
Next
Set myAreas = Sheets("sheet1").Columns("a").SpecialCells(2).Areas
For i = myAreas.Count To 1 Step - 1
With myAreas(i).CurrentRegion
With .Resize(1, .Columns.Count - 1).Offset(, 1)
ReDim a(1 To 2, 1 To .Columns.Count)
For ii = 1 To .Columns.Count
a(1, ii) = .Cells(i).Value
If dic.exists(.Cells(ii).Value) Then
a(2, ii) = dic(.Cells(ii).Value)
End If
Next
HSortMA a, 1, UBound(a, 2), 2
ReDim b(1 To Application.RoundUp(UBound(a, 2) / 5, 0), 1 To 5)
n = 0 : t = 1
For i = 1 To UBound(a, 2)
n = n + 1 : b(t, n) = a(i, 1)
If n = 5 Then
n = 0 : t = t + 1
End If
With .Offset(1).Resize(n, 5)
.EntireRow.Insert
.Value = b
End With
End With
End If
Next
End Sub
(seiya)
seiyaさん ありがとうございます。 データが変わってしまったり、すみませんでした。 他の者と吟味しながら、新しく作るものだったので 内容や形式が変更なったりしてしまいました。
このデータ方式で確定なので質問させていただきました。
Sub test()
Dim myAreas As Areas, a(), b(), i As Long, ii As Long, n As Long, t As Long
Dim dic As Object
Set dic = CreateObject("Scripting.Dictionary")
a = Sheets("sheet2").Range("a1").CurrentRegion.Value
For i = 2 To UBound(a, 1)
dic(a(i, 3)) = i - 1
Next
Set myAreas = Sheets("sheet1").Columns("a").SpecialCells(2).Areas
For i = myAreas.Count To 1 Step - 1
With myAreas(i).CurrentRegion
With .Resize(1, .Columns.Count - 1).Offset(, 1)
ReDim a(1 To 2, 1 To .Columns.Count)
For ii = 1 To .Columns.Count
a(1, ii) = .Cells(i).Value
If dic.exists(.Cells(ii).Value) Then
a(2, ii) = dic(.Cells(ii).Value)
End If
Next
HSortMA a, 1, UBound(a, 2), 2
ReDim b(1 To Application.RoundUp(UBound(a, 2) / 5, 0), 1 To 5)
n = 0 : t = 1
For i = 1 To UBound(a, 2) <--------この部分
n = n + 1 : b(t, n) = a(i, 1)
If n = 5 Then
n = 0 : t = t + 1
End If
With .Offset(1).Resize(n, 5)
.EntireRow.Insert
.Value = b
End With
End With
End If
Next
End Sub
For i = 1 To UBound(a, 2) ここで すでにForの変数が使用されているとコンパイルエラーがでました。
変数をxと定義してみましたが n = n + 1: b(t, n) = a(x, 1)のインデックスが有効範囲でないとなりました。
いろいろすみませんでした。
（もののけ姫）
おっと、またかぶりました
その部分の変数を i から ii に変更してください。 それと Next が抜けていました
For ii = 1 To UBound(a, 2)
n = n + 1 : b(t, n) = a(ii, 1)
If n = 5 Then
n = 0 : t = t + 1
End If
Next
(seiya)
私も作ってみました。
Sheet2は順位順に並んでいる必要が有ります。
'------ Sub mononoke() Dim dic1 As Object, dci2 As Object Dim tbl1, tbl2, x, y, tn Dim i As Long, ii As Long, yi As Long
Set dic1 = CreateObject("Scripting.Dictionary")
Set dic2 = CreateObject("Scripting.Dictionary")
tbl1 = Sheets("Sheet1").Range("A1").CurrentRegion.Resize(6)
For i = 1 To UBound(tbl1, 1)
If tbl1(i, 1) <> "" Then
tn = tbl1(i, 1)
dic1(tn) = dic1.Count + 1
End If
For ii = 1 To UBound(tbl1, 2)
If tbl1(i, ii) <> "" Then
dic2(tbl1(i, ii)) = tn
End If
Next
Next
tbl2 = Sheets("Sheet2").Range("A1").CurrentRegion.Resize(, 3)
ReDim x(1 To dic1.Count, 0 To dic2.Count)
For i = 2 To UBound(tbl2, 1)
If tbl2(i, 3) <> "" Then
If dic2.exists(tbl2(i, 3)) Then
tn = dic1(dic2(tbl2(i, 3)))
x(tn, 0) = x(tn, 0) + 1
x(tn, x(tn, 0)) = tbl2(i, 3)
End If
End If
Next
ReDim y(1 To UBound(tbl1, 1), 1 To 6)
For Each tn In dic1.keys
yi = yi + 1
y(yi, 1) = tn
For i = 1 To x(dic1(tn), 0)
If i <> 1 And i Mod 5 = 1 Then
yi = yi + 1
End If
y(yi, IIf((i Mod 5) = 0, 5, (i Mod 5)) + 1) = x(dic1(tn), i)
Next
Next
With Sheets("Sheet1")
.Range("A:F").ClearContents
.Range("A1").Resize(yi, 6) = y
End With
Set dic1 = Nothing Set dic2 = Nothing End Sub '------
(HANA)
因みに、最後に載せられたサンプルデータは 名前がしっかり被っていますが そう言うことも有るのですか？
でしたら、私のコードは使えません。
同地区内でも同じ名前があるので 単にサンプルデータがいい加減なのかと 思って作成しましたが。。。
(HANA)
seiyaさん
修正ありがとうございます。
差し替えたところ、
HSortMA a, 1, UBound(a, 2), 2
ReDim b(1 To Application.RoundUp(UBound(a, 2) / 5, 0), 1 To 5)
n = 0: t = 1
For ii = 1 To UBound(a, 2)
n = n + 1: b(t, n) = a(ii, 1) <----この部分
~~~~~~~~~~~~~~~~~~~~
If n = 5 Then
n = 0: t = t + 1
End If
Next
インデックスの有効範囲にありません。となりました。
ひとつずつ、ステップアップで確認しているのですが、loop後？の処理以降で止まってる感じがします。
HANAさん さっそくテストしてみました。 同地区内では、同じ担当名はかぶっています・・。 それが原因だったのでしょうか。 かぶっている名前が削除されたように実行後の人数が減っていました・・
（もののけ姫）
えっと・・・もう一度確認ですが Aさんの名前が「横浜地区」に２回出てきて 「川崎地区」にも出てくる事が有る と言う事ですか？
＞同地区内では、同じ担当名はかぶっています・・。 って事は、違う地区に名前はない って事かな？
「横浜地区」に２回有った場合 名前が前後に二つ並べば良いのですか？
(HANA)
いけね その部分 1 とiiが逆になっています。
n = n + 1: b(t, n) = a(1, ii)
(seiya)
seiyaさん
With .Offset(1).Resize(n, 5) <--- この部分が
.EntireRow.Insert
.Value = b
End With
アプリケーションかオブジェクト定義のエラーとなってしまいました。 データのほうが不備なのでしょうか＾＾；
HANAさん あっ・・すみません。 サンプル用の同地区のは、頭文字でしてかぶることはありません。 勘違いしていました・・。
他の地区と名前がかぶることはあります。 複数担当している名前がある場合は、横浜と川崎で同じ名前は挙がってきます。
説明不足でみなさますみません；；
（もののけ姫）
それじゃ、こんな感じでどうでしょう？
'------ Sub mononoke_3() Dim dic1 As Object, dci2 As Object Dim tbl1, tbl2, x, y, z, tn Dim i As Long, ii As Long, yi As Long
Set dic1 = CreateObject("Scripting.Dictionary")
Set dic2 = CreateObject("Scripting.Dictionary")
tbl1 = Sheets("Sheet1").Range("A1").CurrentRegion.Resize(, 6)
For i = 1 To UBound(tbl1, 1)
If tbl1(i, 1) <> "" Then
tn = tbl1(i, 1)
dic1(tn) = dic1.Count + 1
End If
For ii = 1 To UBound(tbl1, 2)
If tbl1(i, ii) <> "" Then
dic2(tbl1(i, ii)) = dic2(tbl1(i, ii)) & "," & tn
End If
Next
Next
tbl2 = Sheets("Sheet2").Range("A1").CurrentRegion.Resize(, 3)
ReDim x(1 To dic1.Count, 0 To UBound(tbl1, 1) * 5)
For i = 2 To UBound(tbl2, 1)
If tbl2(i, 3) <> "" Then
If dic2.exists(tbl2(i, 3)) Then
z = Split(dic2(tbl2(i, 3)), ",")
For ii = 1 To UBound(z)
tn = dic1(z(ii))
x(tn, 0) = x(tn, 0) + 1
x(tn, x(tn, 0)) = tbl2(i, 3)
Next
End If
End If
Next
ReDim y(1 To UBound(tbl1, 1), 1 To 6)
For Each tn In dic1.keys
yi = yi + 1
y(yi, 1) = tn
For i = 1 To x(dic1(tn), 0)
If i <> 1 And i Mod 5 = 1 Then
yi = yi + 1
End If
y(yi, IIf((i Mod 5) = 0, 5, (i Mod 5)) + 1) = x(dic1(tn), i)
Next
Next
With Sheets("Sheet1")
.Range("A:F").ClearContents
.Range("A1").Resize(yi, 6) = y
End With
Set dic1 = Nothing Set dic2 = Nothing End Sub '------
(HANA)
これでどうでしょう？
Sub test()
Dim myAreas As Areas, a(), b(), i As Long, ii As Long, n As Long, t As Long
Dim dic As Object
Set dic = CreateObject("Scripting.Dictionary")
a = Sheets("sheet2").Range("a1").CurrentRegion.Value
For i = 2 To UBound(a, 1)
dic(a(i, 3)) = i - 1
Next
Set myAreas = Sheets("sheet1").Columns("a").SpecialCells(2).Areas
For i = myAreas.Count To 1 Step - 1
With myAreas(i).CurrentRegion
With .Resize(1, .Columns.Count - 1).Offset(, 1)
ReDim a(1 To 2, 1 To .Columns.Count)
For ii = 1 To .Columns.Count
a(1, ii) = .Cells(i).Value
If dic.exists(.Cells(ii).Value) Then
a(2, ii) = dic(.Cells(ii).Value)
End If
Next
HSortMA a, 1, UBound(a, 2), 2
ReDim b(1 To Application.RoundUp(UBound(a, 2) / 5, 0), 1 To 5)
n = 0 : t = 1
For ii = 1 To UBound(a, 2)
n = n + 1 : b(t, n) = a(1, ii)
If n = 5 Then
n = 0 : t = t + 1
End If
With .Offset(1).Resize(t, 5)
.EntireRow.Insert
.Value = b
End With
End With
End If
Next
End Sub
(seiya)
HANAさん
横浜地区 Aさん Xさん Rさん Cさん Nさん Tさん Iさん Fさん Iさん Bさん Bさん Rさん Sさん Rさん Sさん Sさん 川崎地区 Iさん Nさん Nさん Fさん Mさん Bさん Nさん Gさん Cさん Pさん Aさん Sさん Mさん Zさん Zさん Xさん Tさん Sさん
を、実行したところ 結果 横浜地区 Aさん Fさん Cさん Xさん Iさん Iさん Bさん 川崎地区 Iさん Fさん Cさん
となっていました・・。貼りつけかたがおかしいのでしょうか；
seiyaさん
Set myAreas = Sheets("sheet1").Columns("a").SpecialCells(2).Areas
For i = myAreas.Count To 1 Step - 1
With myAreas(i).CurrentRegion
With .Resize(1, .Columns.Count - 1).Offset(, 1)
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
ReDim a(1 To 2, 1 To .Columns.Count)
For ii = 1 To .Columns.Count
a(1, ii) = .Cells(i).Value
If dic.exists(.Cells(ii).Value) Then
a(2, ii) = dic(.Cells(ii).Value)
End If
Next
HSortMA a, 1, UBound(a, 2), 2
ReDim b(1 To Application.RoundUp(UBound(a, 2) / 5, 0), 1 To 5)
n = 0 : t = 1
For ii = 1 To UBound(a, 2)
n = n + 1 : b(t, n) = a(1, ii)
If n = 5 Then
n = 0 : t = t + 1
End If
NEXT <-------------- 挿入
With .Offset(1).Resize(t, 5)
.EntireRow.Insert
.Value = b
End With
End With
End If <------------- withに変更
Next
End Sub
「実行前」
横浜地区 Aさん Xさん Rさん Cさん Nさん Tさん Iさん Fさん Iさん Bさん Bさん Rさん Sさん Rさん Sさん Sさん 川崎地区 Iさん Nさん Nさん Fさん Mさん Bさん Nさん Gさん Cさん Pさん Aさん Sさん Mさん Zさん Zさん Xさん Tさん Sさん
「実行後」
横浜地区 Aさん Xさん Rさん Cさん Nさん Sさん
Xさん Xさん Xさん Xさん Xさん Xさん Xさん Xさん Xさん Xさん
川崎地区 Iさん Nさん Nさん Fさん Mさん Sさん
Nさん Nさん Nさん Nさん Nさん Nさん Nさん Nさん Nさん Nさん Xさん Tさん
結果がこのようになってしまいました・・。 サンプルどおりの貼り付けをしているのですが、わたしだけでしょうか・・。
（もののけ姫）
あ〜・・・済みません 間違えてます。
＞tbl1 = Sheets("Sheet1").Range("A1").CurrentRegion.Resize(6)
は、
→tbl1 = Sheets("Sheet1").Range("A1").CurrentRegion.Resize(, 6)
です。
上のコードは直接変更しておきます。
因みに、Sheet2に名前が無い人は削除されますので （順番がつけられませんので） データ量が減る可能性は有ります。
(HANA)
> 「実行前」
横浜地区 Aさん Xさん Rさん Cさん Nさん Tさん Iさん Fさん Iさん Bさん Bさん Rさん Sさん Rさん Sさん Sさん 川崎地区 Iさん Nさん Nさん Fさん Mさん Bさん Nさん Gさん Cさん Pさん Aさん Sさん Mさん Zさん Zさん Xさん Tさん Sさん
これは想定していませんでした...
Sub test()
Dim myAreas As Areas, a(), b(), i As Long, ii As Long, n As Long, t As Long
Dim dic As Object
Set dic = CreateObject("Scripting.Dictionary")
a = Sheets("sheet2").Range("a1").CurrentRegion.Value
For i = 2 To UBound(a, 1)
dic(a(i, 3)) = i - 1
Next
With Sheets("Sheet1")
.Columns(1).Insert
With .Range("c2", .Range("c" & Rows.Count).End(xlUp)).Offset(, -2)
.Formula = "=if(b2<>"""",1,"""")"
.SpecialCells(-4123, 1).EntireRow.Insert
End With
.Columns(1).Delete
End With
Set myAreas = Sheets("sheet1").Columns("a").SpecialCells(2).Areas
For i = myAreas.Count To 1 Step - 1
With myAreas(i).CurrentRegion
With .Resize(, .Columns.Count - 1).Offset(, 1)
ReDim a(1 To 2, 1 To .Cells.Count)
For ii = 1 To .Rows.Count
For iii = 1 To .Columns.Count
n = n + 1 : b(1, n) = .Cells(ii, iii).Value
If dic.exists(.Cells(ii,iii).Value) Then
a(2, n) = dic(.Cells(ii, iii).Value)
End If
Next iii, ii
.CelarContents
HSortMA a, 1, UBound(a, 2), 2
ReDim b(1 To Application.RoundUp(UBound(a, 2) / .Columns.Count, 0), 1 To .Columns.Count)
n = 0 : t = 1
For i = 1 To UBound(a, 2)
n = n + 1 : b(t, n) = a(i, 1)
If n = .Columns.Count Then
n = 0 : t = t + 1
End If
Next
.Value = b
End With
End With
Next
End Sub
(seiya)
HANAさん seiyaさん
ありがとうございます！！完璧で理想なデータとなりました（涙）
長期にわたり、みなさまにお時間いただきましてありがとうございました。
ど素人な質問にお答えくださいまして感謝感激です。
また、煮詰まったとき よろしくお願いします。
（もののけ姫）
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.