[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『一覧から日毎のまとめ表を作りたい』（初心者）
一覧表の日ごとの出席まとめを作りたい。
＜一覧表シート＞ ／はセルの切り替えです。
Ｃ ／ Ｄ ／ Ｅ ／ Ｆ ／ Ｇ ／Ｈ・・・・７０列まで続く
４） クラス／学籍番号／名前／性別／1月1日／1月2日／・・・・
５） Ｂ／111／田中太郎／男／出席／早退／
６） Ｂ／123／山田花子／女／出席／／
７） Ｃ／444／木村洋子／女／／早退／
８） Ｃ／222／佐々木龍之介／男／早退／出席／
９） Ｄ／332／中村修二／男／／出席／
９） Ｅ／532／中山仁太／男／出席／出席／
・
・
・
２００行まで続く
上記のようにデータが有って、欠席はブランク、以外は何かしらデータが入っています。
＜日ごと＞
Ｂ ／ Ｃ ／ Ｄ ／ Ｅ ／ Ｆ ／ Ｇ ／Ｈ
１） 1月1日
２） クラス／学籍番号／名前
３） Ｂ／111.123／田中太郎.山田花子
４） Ｃ／222／佐々木龍之介
５） Ｅ／532／中山仁太
・
・
・
シートのセルＢ１に日付を入れるとＢ３以降にまとめデータを表示させたいのですが
関数とかで出来ますか？
どの様に作ればいいか全く見当が付かず、、、
アドバイスお願いします。
＜ 使用 Excel：Excel2007、使用 OS：Windows8 ＞
＞３） Ｂ／111.123／田中太郎.山田花子
実際には、30人程度が、１つのセルに列挙されるのですか？
本当に、そんなレイアウトでよいのでしょうか。
（マナ） 2019/06/20(木) 18:53
【一覧表】シート
______C________D________E_______F____G______H______I______J____ 4 クラス 学籍番号 名前 性別 1/1 1/2 1/3 1/4 5 Ｂ 111 田中太郎 男 出席 早退 6 Ｂ 123 山田花子 女 出席 7 Ｃ 444 木村洋子 女 早退 8 Ｃ 222 佐木龍介 男 早退 出席 9 Ｄ 332 中村修二 男 出席 10 Ｅ 532 中山仁太 男 出席 出席
【日ごと】シート
_____B________C__________D______ 1 1/1 2 クラス 学籍番号 名前 3 Ｂ 111.123 田中太郎.山田花子 4 Ｃ 222 佐木龍介 5 Ｅ 532 中山仁太
出来ないとは断言しませんが、数式だとかなり難しそう。
マクロなら頑張ればできる・・・・かも。
まずは、数式とマクロどちらでいくのかを決めてから相談されたほうがよいかもしれません。
ただ、マクロの場合でも、オートフィルタなどで抽出したりする部分はともかくとして、TRANSPOSE関数を使って行列を入れ替えたり、Join関数を使って文字列をくっつけたりしなければいけないようにおもうので、マクロの記録をベースに改造していくといった手法が使えず、積極的に情報収集（自分で考えて作っていく作業）をしないと完成しないとおもいますのでそれなりの覚悟は必要になりそうです。
※簡単にやる方法もあるのかもしれませんが、いまのところ思いつかないです。
（もこな２） 2019/06/20(木) 19:38
わたしが関数が得意ではないのでという意味です。
マクロだと、Dictionaryを使う回答が多いです。
（マナ） 2019/06/20(木) 19:53
関数では難しいのですね。。。
マクロは使ったことないのでハードルが高そうです。
あと、1クラス最大１２人なので一つのセルにはそんなに入らないです。
レイアウトは前任者から引き継いだのですが、手入力で転記されていた感じです。
ややこしいのですごく時間がかかってしまっているので、質問させていただいたのですが
１日一回の作業なので手でやった方がいいのかもしれません。
（初心者） 2019/06/20(木) 21:14
Option Explicit
Sub test()
Dim dic As Object
Dim tbl As Range
Dim m
Dim c As Range
Dim クラス As String
Dim 学籍番号 As String
Dim 名前 As String
Set tbl = Sheets("一覧表").Range("a4").Resize(300, 365)
m = Application.Match(Range("a1"), tbl.Rows(1), 0)
If IsError(m) Then Exit Sub
ActiveSheet.UsedRange.Offset(2).ClearContents
If WorksheetFunction.CountA(tbl.Columns(m)) = 1 Then Exit Sub
Set dic = CreateObject("scripting.dictionary")
For Each c In tbl.Offset(1).Columns(m).SpecialCells(xlCellTypeConstants)
クラス = c.EntireRow.Range("a1").Value
学籍番号 = c.EntireRow.Range("b1").Value
名前 = c.EntireRow.Range("c1").Value
If Not dic.exists(クラス) Then
dic(クラス) = Array(クラス, 学籍番号, 名前)
Else
dic(クラス) = Array(クラス, dic(クラス)(1) & "." & 学籍番号, dic(クラス)(2) & "." & 名前)
End If
Next
Range("a3").Resize(dic.Count, 3).Value = Application.Index(dic.items, 0, 0)
End Sub
（マナ） 2019/06/20(木) 22:03
ボタンと「標準モジュール」にせっとが完了してボタンを押してみたのですが
何も起こらない状態です。
登録がおかしいのでしょうか？
何度もすいませんが、教えて頂けると嬉しいです。
（初心者） 2019/06/21(金) 10:56
別案で
1) >７０列まで続く
曖昧なので範囲をC4:BR500と想定。
2) 4行目G列以降の項目はシリアル値の日付であること。例 2019/1/1
3) 日ごとシートのB1はシリアル値の日付であること。例：同上
3) シート名、列項目名が提示された通りであること。
上記が満たされていれば動作するを当方で確認済み。
Sub test()
Dim cn As Object, rs As Object, myDay
Dim a, x, y, i As Long, ii As Long, iii As Long
Application.ScreenUpdating = False
myDay = CLng(Sheets("日ごと").[b1])
Set cn = CreateObject("ADODB.Connection")
Set rs = CreateObject("ADODB.Recordset")
With cn
.Provider = "Microsoft.Ace.OLEDB.12.0"
.Properties("Extended Properties") = "Excel 12.0; HDR=Yes;"
.Open ThisWorkbook.FullName
End With
Sheets("日ごと").[b1].CurrentRegion.Offset(2).ClearContents
rs.Open "Select Distinct `クラス` From `一覧表シート$c4:br500` Where `" & _
myDay & "` Is Not Null Order By `クラス`;", cn, 3
If rs.RecordCount Then
x = rs.GetRows: rs.Close
rs.Open "Select `クラス`, `学籍番号`, `名前` From `一覧表シート$c4:br500` " & _
"Where `" & myDay & "` Is Not Null;", cn, 3, 3, 1
For i = 0 To UBound(x, 2)
rs.Filter = "クラス = '" & x(0, i) & "'"
y = rs.GetRows
ReDim a(1 To UBound(y, 1) + 1): a(1) = x(0, i)
For ii = 1 To UBound(y, 1)
For iii = 0 To UBound(y, 2)
a(ii + 1) = a(ii + 1) & IIf(a(ii + 1) <> "", ".", "") & y(ii, iii)
Next
Next
Sheets("日ごと").Cells(i + 3, 2).Resize(, UBound(a)).Value = a
Next
End If
Set cn = Nothing: Set rs = Nothing
End Sub
（seiya） 2019/06/21(金) 11:47
他の方もありがとうございました！
（初心者） 2019/06/21(金) 12:57
動作確認が出来たら、下記コードと差し替えてください。
ADOは開いているブックに接続するとメモリーリークが発生することが報告されていますので。
Sub test()
Dim cn As Object, rs As Object, fn As String, myDay
Dim a, x, y, i As Long, ii As Long, iii As Long
Application.ScreenUpdating = False
fn = ThisWorkbook.Path & "\temp.xlsm"
ThisWorkbook.SaveCopyAs fn
myDay = Sheets("日ごと").[b1]
Set cn = CreateObject("ADODB.Connection")
Set rs = CreateObject("ADODB.Recordset")
With cn
.Provider = "Microsoft.Ace.OLEDB.12.0"
.Properties("Extended Properties") = "Excel 12.0; HDR=Yes;"
.Open fn
End With
Sheets("日ごと").[b1].CurrentRegion.Offset(2).ClearContents
rs.Open "Select Distinct `クラス` From `一覧表シート$c4:br500` Where `" & myDay & "` Is Not Null;", cn, 3
If rs.RecordCount Then
x = rs.GetRows: rs.Close
rs.Open "Select `クラス`, `学籍番号`, `名前` From `一覧表シート$c4:br500` " & _
"Where `" & myDay & "` Is Not Null;", cn, 3, 3, 1
For i = 0 To UBound(x, 2)
rs.Filter = "クラス = '" & x(0, i) & "'"
y = rs.GetRows
ReDim a(1 To UBound(y, 1) + 1): a(1) = x(0, i)
For ii = 1 To UBound(y, 1)
For iii = 0 To UBound(y, 2)
a(ii + 1) = a(ii + 1) & IIf(a(ii + 1) <> "", ".", "") & y(ii, iii)
Next
Next
Sheets("日ごと").Cells(i + 3, 2).Resize(, UBound(a)).Value = a
Next
End If
Set cn = Nothing: Set rs = Nothing
Kill fn
End Sub
（seiya） 2019/06/21(金) 13:48
二つ目のコードをコピーしたら下記のメッセージが出てきました。
実行時エラー'-2147217904（80040e10)
１つ以上の必要なパラメーターの値が設定されていません。
そのあと戻しても同じメッセージが出ます。
どういう意味なのでしょうか？
（初心者） 2019/06/21(金) 20:56
> myDay = Sheets("日ごと").[b1]
を
myDay = CLng(Sheets("日ごと").[b1])
にしてください。
（seiya） 2019/06/21(金) 21:02
教えていただいた箇所を貼り替えましたが変わらずです。。
rs.Open "Select Distinct `クラス` From `一覧表シート$c4:br500` Where `" & myDay & "` Is Not Null;", cn, 3
の場所が黄色くなっているのですが何か関係があるのでしょうか？
（初心者） 2019/06/24(月) 10:08
こちらでは myDay = Sheets("日ごと").[b1] でうまく動いてますが...
> Dim cn As Object, rs As Object, fn As String, myDay これをmyDayをDate型に指定して
Dim cn As Object, rs As Object, fn As String, myDay As Date
myDayを
myDay = Sheets("日ごと").[b1]
で試してください。
（seiya） 2019/06/24(月) 11:18
Dim dic1 As Object, dic2 As Object, k As Variant, r As Range, c As Range
Set dic1 = CreateObject("Scripting.Dictionary")
Set dic2 = CreateObject("Scripting.Dictionary")
Set r = Sheets("一覧表").Rows(4).Find(Sheets("日ごと").Range("B1").Value, , , xlWhole)
If WorksheetFunction.CountA(Sheets("一覧表").Range(r.Offset(1), Sheets("一覧表").Cells(Rows.Count, r.Column))) = 0 Then Exit Sub
For Each c In Sheets("一覧表").Range(r.Offset(1), Sheets("一覧表").Cells(Rows.Count, r.Column)).SpecialCells(2)
If c.Value <> "" Then
dic1(c.EntireRow.Cells(3).Value) = dic1(c.EntireRow.Cells(3).Value) & "." & c.EntireRow.Cells(4).Value
dic2(c.EntireRow.Cells(3).Value) = dic2(c.EntireRow.Cells(3).Value) & "." & c.EntireRow.Cells(5).Value
End If
Next c
Sheets("日ごと").Rows("2:" & Rows.Count).ClearContents
Sheets("日ごと").Range("B2").Resize(, 3).Value = Array("クラス", "学籍番号", "名前")
For Each k In dic1
Sheets("日ごと").Range("B" & Rows.Count).End(xlUp).Offset(1).Resize(, 3).Value = Array(k, Mid(dic1(k), 2), Mid(dic2(k), 2))
Next k
End Sub
（mm） 2019/06/24(月) 12:59
ありがとうございました！
（初心者） 2019/06/25(火) 09:27
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.