Results of 1 - 1 of about 48829 for A�����������������������... (0.010 sec.)
- [[20090627005959]]
- #score: 1420
- @digest: a1bf2f93ea018d2fac9f0e2f14e59c8c
- @id: 44209
- @mdate: 2009-06-30T08:10:12Z
- @size: 32682
- @type: text/plain
- #keywords: hsortma (158693), myareas (101552), 浜地 (86561), んn (77516), んs (70081), 崎地 (68588), 谷地 (64439), 区i (56043), んx (55264), 地区 (55015), んt (53658), 区a (51514), んz (49880), んi (47828), 田地 (47687), んr (41157), んf (31969), tmpws (25503), myarea (19852), 川崎 (18312), んc (16815), 姫） (16021), tbl1 (15619), んb (15273), 千代 (15210), 代田 (14624), 横浜 (13078), dic1 (13035), areas (9118), ubound (7966), columns (6823), ary (6060)
- 『数値と名前の抽出』（もののけ姫）
こんばんわ。 皆様にご指導していただきたく、書き込みします。 今回、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人区切りで行を増やしています。 マクロ後、並び替えが一行に設定してあるものを、数行（5人x*行）で並び替えも可能でしょうか。 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) ---- >マクロ後、並び替えが一行に設定してあるものを、数行（5人x*行）で並び替えも可能でしょうか。 期待する結果はどのような感じになるのでしょう? (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 f 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（実際はもっとあります）の中で 5人ずつに分けて記入しているので 渋谷地区のように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 がかぶっていますね... という誤りに気づかれて、修正されているのですが、もののけ姫さんが先ほど提示されたコードでは、 そのコードになっていません。 再度、ご確認されてはいかがでしょうか? なお、 > マクロ後、並び替えが一行に設定してあるものを、数行（5人x*行）で並び替えも可能でしょうか。 の追加要件は、確認していません。 (とおりすがり) ---- とおりすがりさん 申し訳ありません・・こちらでした。 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 f 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さんの名前が「横浜地区」に2回出てきて 「川崎地区」にも出てくる事が有る と言う事ですか? ＞同地区内では、同じ担当名はかぶっています・・。 って事は、違う地区に名前はない って事かな? 「横浜地区」に2回有った場合 名前が前後に二つ並べば良いのですか? (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さん ありがとうございます!!完璧で理想なデータとなりました（涙） 長期にわたり、みなさまにお時間いただきましてありがとうございました。 ど素人な質問にお答えくださいまして感謝感激です。 また、煮詰まったとき よろしくお願いします。 （もののけ姫）... - http://www.excel.studio-kazu.jp/wiki/kazuwiki/200906/20090627005959.txt - [detail] - similar
PREV
NEXT
Powered by Hyper Estraier 1.4.13, with 97013 documents and 608132 words.
訪問者：