[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『卒業者台帳を作成したいです。』(るっく)
「生徒情報シート」から情報を取得して、「授与台帳シート」に貼り付けたいです。
その際、下の図のように、10名を左側(A6セル〜)に貼り付け、次の10名を右側(G6セル〜)に貼り付け、その次の10名を左側(A16セル〜)に貼り付け、というように、左右を互い違いに貼り付けることはできますか?
自分でコードを書こうとしたのですが、頭がパンクしてわけがわからなくなりました。
|[A] |[B] |[C] |[D] |[E] |[F]|[G] |[H] |[I] |[J] |[K] [5] |証書番号|卒業年月日 |氏 名 |生年月日 |備 考| |証書番号|卒業年月日 |氏 名|生年月日 |備 考 [6] |第1号 |令和5年3月31日|塩谷 小夏 |平成22年12月29日生| | |第11号 |令和5年3月31日|黒沢 璃乃|平成22年4月28日生 | [7] |第2号 |令和5年3月31日|森下 依子 |平成22年5月23日生 | | |第12号 |令和5年3月31日|竹村 結花|平成22年8月28日生 | [8] |第3号 |令和5年3月31日|南 真琴 |平成22年10月23日生| | |第13号 |令和5年3月31日|川田 和裕|平成22年6月16日生 | [9] |第4号 |令和5年3月31日|織田 敏哉 |平成22年5月4日生 | | |第14号 |令和5年3月31日|神谷 泰佑|平成22年8月10日生 | [10]|第5号 |令和5年3月31日|長谷部 志帆|平成22年5月6日生 | | |第15号 |令和5年3月31日|大河原 樹|平成22年4月17日生 | [11]|第6号 |令和5年3月31日|金野 光子 |平成22年8月12日生 | | |第16号 |令和5年3月31日|田代 道雄|平成22年8月27日生 | [12]|第7号 |令和5年3月31日|杉原 武秀 |平成22年10月31日生| | |第17号 |令和5年3月31日|風間 有香|平成22年8月2日生 | [13]|第8号 |令和5年3月31日|田口 信次 |平成22年4月3日生 | | |第18号 |令和5年3月31日|大谷 文 |平成23年3月31日生 | [14]|第9号 |令和5年3月31日|宮地 雫 |平成22年11月5日生 | | |第19号 |令和5年3月31日|松村 香音|平成22年9月13日生 | [15]|第10号 |令和5年3月31日|松木 珠希 |平成23年1月14日生 | | |第20号 |令和5年3月31日|南田 拓歩|平成22年6月10日生 | [16]|第21号 |令和5年3月31日|難波 愛奈 |平成22年6月23日生 | | |第31号 |令和5年3月31日|杉浦 早苗|平成22年9月13日生 | [17]|第22号 |令和5年3月31日|本山 遥花 |平成22年11月19日生| | |第32号 |令和5年3月31日|金丸 圭子|平成22年6月10日生 | [18]|第23号 |令和5年3月31日|市原 孝義 |平成22年12月14日生| | |第33号 |令和5年3月31日|栗山 基一|平成22年11月19日生| [19]|第24号 |令和5年3月31日|丸田 弓斗 |平成23年3月12日生 | | |第34号 |令和5年3月31日|川田 正三|平成22年12月14日生| [20]|第25号 |令和5年3月31日|小峰 梨々那|平成23年2月15日生 | | |第35号 |令和5年3月31日|熊田 裕一|平成22年11月20日生| [21]|第26号 |令和5年3月31日|大内 峻輝 |平成22年8月24日生 | | |第36号 |令和5年3月31日|蛭田 朱音|平成22年12月15日生| [22]|第27号 |令和5年3月31日|勝田 孝吉 |平成22年6月18日生 | | |第37号 |令和5年3月31日|重田 志歩|平成22年11月21日生| [23]|第28号 |令和5年3月31日|西岡 真希 |平成23年1月9日生 | | |第38号 |令和5年3月31日|三枝 直人|平成22年12月16日生| [24]|第29号 |令和5年3月31日|澤田 紫雲 |平成22年6月19日生 | | |第39号 |令和5年3月31日|橘 賢次 |平成22年11月22日生| [25]|第30号 |令和5年3月31日|川嶋 風香 |平成23年1月10日生 | | |第40号 |令和5年3月31日|山本 信彦|平成22年12月17日生|
________________________________________________________________
Option Explicit
Sub 授与台帳()
Dim 年 As Long Dim 名前 As String Dim 正式名前 As String Dim 生年月日 As String '変数名は、校務支援ソフトが出力するエクセルファイルに合わせています。 Dim 証書番号 As Long Dim 卒業年 As Variant Dim 最高学年 As Long '小学校でも中学校でも使えるように Dim i As Long Dim j As Long Dim k As Long Dim l As Long Dim lastrow As Long Dim wsS Dim wsD Dim wsJ Set wsS = Worksheets("生徒情報") Set wsD = Worksheets("データベース") Set wsJ = Worksheets("授与台帳")
’「生徒情報」シートの整理
Call 元データのフィルタ解除と重複削除
証書番号 = InputBox("証書番号は何番からスタートしますか?" & vbCrLf & "(半角数字で入力)") 卒業年 = Format(Now, "ggge年") '「生徒情報」シートの学年は文字列のため、そこからは直接数値を取得できない。 ’そのため、わざわざデータベースシートに別途最大学年を入力している。 最高学年 = wsD.Cells(11, 2).Value '内容消去 wsJ.Range("a5").CurrentRegion.Offset(1, 0).ClearContents wsJ.Range("g5").CurrentRegion.Offset(1, 0).ClearContents
============以降、試行錯誤しているうちに、わけわからなくなりました。============
i = 2 j = 6 k = 1 l = 0 Do While wsS.Cells(i, 3).Value <> "" If wsS.Cells(i, 3).Value <> 最高学年 Then i = i + 1 Else 年 = wsS.Cells(i, 3).Value 名前 = wsS.Cells(i, 17).Value 正式名前 = wsS.Cells(i, 19).Value 生年月日 = Format(wsS.Cells(i, 22).Value, "ggge年m月d日")
lastrow = wsS.Cells(Rows.Count, 1).End(xlUp).Row For j = 6 To 15 wsJ.Cells(j, k).Value = "第" & 証書番号 & "号" wsJ.Cells(j, k + 1).Value = 卒業年 & vbCrLf & "3月31日" wsJ.Cells(j, k + 2).Value = 名前 If 正式名前 <> " " Then wsJ.Cells(j, k + 2).Value = 正式名前 End If wsJ.Cells(j, k + 3).Value = 生年月日 & "生" i = i + 1 証書番号 = 証書番号 + 1 Next k = 7 For j = 6 To 15 wsJ.Cells(j, k).Value = "第" & 証書番号 & "号" wsJ.Cells(j, k + 1).Value = 卒業年 & vbCrLf & "3月31日" wsJ.Cells(j, k + 2).Value = 名前 If 正式名前 <> " " Then wsJ.Cells(j, k + 2).Value = 正式名前 End If wsJ.Cells(j, k + 3).Value = 生年月日 & "生" i = i + 1 証書番号 = 証書番号 + 1 Next For j = 2 To lastrow Step 10 Select Case j Case Is < 100 If Left(j, 1) Mod 2 = 0 Then k = 1 Else k = 7 End If Case Is >= 100 If Left(j, 2) Mod 2 = 0 Then k = 1 Else k = 7 End If End Select l = wsJ.Cells(Rows.Count, k).End(xlUp).Offset(1, 0).Row wsS.Cells(j, 1).Resize(10).Copy wsJ.Cells(l, k) Next
Next
End If Loop End Sub
< 使用 Excel:unknown、使用 OS:unknown >
生徒情報シートはどうなっているのですか? ご提示のコードから推理力を働かせて、逆算せよと言うことなんですか?
以下の4人分でいいので、元ネタデータが、どのセルにどう入力されているのか示せませんか?
[6] |第1号 |令和5年3月31日|塩谷 小夏 |平成22年12月29日生| | |第11号 |令和5年3月31日|黒沢 璃乃|平成22年4月28日生 | [7] |第2号 |令和5年3月31日|森下 依子 |平成22年5月23日生 | | |第12号 |令和5年3月31日|竹村 結花|平成22年8月28日生 |
(半平太) 2023/01/26(木) 17:20:25
分離できなければどちらかをループにさせず、その都度足したり引いたりする処理にしましょう。
(お邪魔します) 2023/01/26(木) 18:15:15
ご返信ありがとうございます。
大変失礼しました。
生徒情報シートでは、このように、氏名はQ列に、生年月日はV列に入っています。
第189行よりも上の行には、1年生から5年生までが順に並んでいます。
|[Q] |[V] [189]|塩谷 小夏 [189]|2010/12/29 [190]|森下 依子 [190]|2010/5/23 [191]|南 真琴 [191]|2010/10/23 [192]|織田 敏哉 [192]|2010/5/4 [193]|長谷部 志帆 [193]|2010/5/6 [194]|金野 光子 [194]|2010/8/12 [195]|杉原 武秀 [195]|2010/10/31 [196]|田口 信次 [196]|2010/4/3 [197]|宮地 雫 [197]|2010/11/5 [198]|松木 珠希 [198]|2011/1/14 [199]|黒沢 璃乃 [199]|2010/4/28 [200]|竹村 結花 [200]|2010/8/28 [201]|川田 和裕 [201]|2010/6/16 [202]|神谷 泰佑 [202]|2010/8/10 [203]|大河原 樹 [203]|2010/4/17 [204]|田代 道雄 [204]|2010/8/27 [205]|風間 有香 [205]|2010/8/2 [206]|大谷 文 [206]|2011/3/31 [207]|松村 香音 [207]|2010/9/13 [208]|南田 拓歩 [208]|2010/6/10 [209]|難波 愛奈 [209]|2010/6/23 [210]|本山 遥花 [210]|2010/11/19 [211]|市原 孝義 [211]|2010/12/14 [212]|丸田 弓斗 [212]|2011/3/12 [213]|小峰 梨々那 [213]|2011/2/15 [214]|大内 峻輝 [214]|2010/8/24 [215]|勝田 孝吉 [215]|2010/6/18 [216]|西岡 真希 [216]|2011/1/9
(るっく) 2023/01/26(木) 20:28:41
なるほど、確かにループの入れ子は苦手です。
分割するのもアリですね。大きなヒントをありがとうございます。
(るっく) 2023/01/26(木) 20:30:25
(隠居Z) 2023/01/26(木) 21:39:25
こんなのでいいような気がしますけども
Sub 授与台帳() Dim 年 As Long Dim 名前 As String Dim 正式名前 As String Dim 生年月日 As String Dim 証書番号 As Long Dim 卒業年 As Variant Dim 最高学年 As Long '小学校でも中学校でも使えるように Dim i As Long Dim j As Long Dim wsS Dim wsD Dim wsJ Dim rowToWrite Dim colToWrite '変数名は、校務支援ソフトが出力するエクセルファイルに合わせています。 Set wsS = Worksheets("生徒情報") Set wsD = Worksheets("データベース") Set wsJ = Worksheets("授与台帳") '「生徒情報」シートの整理 ' Call 元データのフィルタ解除と重複削除 ' 証書番号 = InputBox("証書番号は何番からスタートしますか?" & vbCrLf & "(半角数字で入力)") 証書番号 = 1 卒業年 = Format(Now, "ggge年") '「生徒情報」シートの学年は文字列のため、そこからは直接数値を取得できない。 'そのため、わざわざデータベースシートに別途最大学年を入力している。
最高学年 = wsD.Cells(11, 2).Value
'内容消去 wsJ.Range("a5").CurrentRegion.Offset(1, 0).ClearContents wsJ.Range("g5").CurrentRegion.Offset(1, 0).ClearContents '============以降、試行錯誤しているうちに、わけわからなくなりました。============
i = 2 j = 1
Do While wsS.Cells(i, 3).Value <> "" If wsS.Cells(i, 3).Value = 最高学年 Then
年 = wsS.Cells(i, 3).Value 名前 = wsS.Cells(i, 17).Value 正式名前 = wsS.Cells(i, 19).Value 生年月日 = Format(wsS.Cells(i, 22).Value, "ggge年m月d日")
rowToWrite = Application.Floor((j - 1), 20) / 2 + (j - 1) Mod 10 + 6 colToWrite = (Int((j - 1) / 10) Mod 2) * 6 + 1
wsJ.Cells(rowToWrite, colToWrite).Value = "第" & 証書番号 & "号" wsJ.Cells(rowToWrite, colToWrite + 1).Value = 卒業年 & vbCrLf & "3月31日" wsJ.Cells(rowToWrite, colToWrite + 2).Value = 名前
If 正式名前 <> " " Or 正式名前 <> "" Or 正式名前 <> " " Then wsJ.Cells(rowToWrite, colToWrite + 2).Value = 正式名前 End If
wsJ.Cells(rowToWrite, colToWrite + 3).Value = 生年月日 & "生" ' 証書番号 = 証書番号 + 1 j = j + 1 '枚数
End If i = i + 1 Loop End Sub
(半平太) 2023/01/26(木) 23:59:12
解決済みかとは思いますが、別案です。
作業用シートを使うことにして、 (a)"生徒情報"シート ↓ (項目作成、転記) (b)"作業用"シート 2段組ではなく、1段のフラットなシート ↓ (転記) (c)"授与台帳"シート 10行ごとに、コピーペイストします。 としたらどうでしょう。
■ Dim myRow&, myCol& Dim wsTemp As Worksheet といった変数を宣言しておき、 Set wsTemp = Worksheets("作業") ' ■■事前に作成しておいてください。列の書式も適正にセットのこと としておきます。
■ 主要な転記部分のみ示します。(正式名称とかの対応は、説明目的を優先して省略しています)
Rem ■(1)"生徒情報"シートをもとに、"作業"シートに対象者の情報を作成します----- wsTemp.Cells.ClearContents '転記先を初期化(必要なら、書式は事前に整えておいてください) j = 1 For i = 189 To wsS.Cells(Rows.Count, "Q").End(xlUp).Row '189は直接書きました(追加再検討が必要) 名前 = wsS.Cells(i, 17).Value 生年月日 = Format(wsS.Cells(i, 22).Value, "ggge年m月d日") wsTemp.Cells(j, "A").Value = "第" & 証書番号 & "号" wsTemp.Cells(j, "B").Value = 卒業年 & vbCrLf & "3月31日" wsTemp.Cells(j, "C").Value = 名前 wsTemp.Cells(j, "D").Value = 生年月日 & "生" 証書番号 = 証書番号 + 1 j = j + 1 Next
Rem ■(2)"作業"シートの情報を、"授与台帳"シートに転記------------------
'最初の転記先位置 myRow = 6 myCol = 1
For k = 1 To wsTemp.Cells(Rows.Count, "A").End(xlUp).Row Step 10 wsTemp.Cells(k, "A").Resize(10, 4).Copy wsJ.Cells(myRow, myCol)
'次の転記先位置を決める If myCol = 1 Then myCol = 7 ElseIf myCol = 7 Then myCol = 1 myRow = myRow + 10 End If Next End Sub (γ) 2023/01/27(金) 07:18:38
Sub Sample() Const TOP_ROW As Long = 6 '先頭行 Const TOP_COL As Long = 1 '先頭列 Const IV_COL As Long = 6 '列間隔 Const COL_DIV As Long = 2 '列分割数 Const ROW_DIV As Long = 10 '何人ごとに列変更するか
Dim cnt As Long Dim iCl As Long, iRw As Long Dim i As Long, j As Long, k As Long Dim r As Long, c As Long
cnt = Application.InputBox("データ数を入力", Type:=1)
For i = 0 To (cnt - 1) \ (COL_DIV * ROW_DIV) For j = 0 To COL_DIV - 1 iCl = j * IV_COL + TOP_COL For k = 0 To ROW_DIV - 1 r = i * (COL_DIV * ROW_DIV) + j * ROW_DIV + k If r >= cnt Then Exit For iRw = i * ROW_DIV + k + TOP_ROW For c = 0 To 3 Cells(iRw, iCl + c).Value = "Array(" & r & "," & c & ")" Next Next k Next j Next i End Sub (お邪魔します) 2023/01/27(金) 11:54:24
|[A] |[B] |[C] |[D] [1]| | | | [2]|Array(0,0)|Array(0,1)|Array(0,2)|Array(0,3) [3]|Array(1,0)|Array(1,1)|Array(1,2)|Array(1,3) [4]|Array(2,0)|Array(2,1)|Array(2,2)|Array(2,3)
Const Top_Row As Long = 2 '先頭行 Const Top_Columns As Long = 1 '先頭列 Const 列間隔 As Long = 3 '列間隔 Const 列分割数 As Long = 2 '列分割数 Const 何人ごとに列変更するか As Long = 10 '何人ごとに列変更するか
cnt = Application.InputBox("データ数を入力", Type:=1) cnt=3
'==================================================================================
|[A] |[B] |[C] |[D] |[E] |[F] |[G] [1] | | | | | | | [2] |Array(0,0)|Array(0,1)|Array(0,2)|Array(10,0)|Array(10,1)|Array(10,2)|Array(10,3) [3] |Array(1,0)|Array(1,1)|Array(1,2)|Array(11,0)|Array(11,1)|Array(11,2)|Array(11,3) [4] |Array(2,0)|Array(2,1)|Array(2,2)|Array(12,0)|Array(12,1)|Array(12,2)|Array(12,3) [5] |Array(3,0)|Array(3,1)|Array(3,2)|Array(13,0)|Array(13,1)|Array(13,2)|Array(13,3) [6] |Array(4,0)|Array(4,1)|Array(4,2)|Array(14,0)|Array(14,1)|Array(14,2)|Array(14,3) [7] |Array(5,0)|Array(5,1)|Array(5,2)|Array(5,3) | | | [8] |Array(6,0)|Array(6,1)|Array(6,2)|Array(6,3) | | | [9] |Array(7,0)|Array(7,1)|Array(7,2)|Array(7,3) | | | [10]|Array(8,0)|Array(8,1)|Array(8,2)|Array(8,3) | | |
Const Top_Row As Long = 2 '先頭行 Const Top_Columns As Long = 1 '先頭列 Const 列間隔 As Long = 3 '列間隔 Const 列分割数 As Long = 2 '列分割数 Const 何人ごとに列変更するか As Long = 10 '何人ごとに列変更するか
cnt = Application.InputBox("データ数を入力", Type:=1) cnt=15
(やってみた) 2023/01/27(金) 12:55:56
Option Explicit Sub DataBaseColumns_WrightToOherWorkSheetAandG_Main() Dim v() As Variant Dim aAry() As Variant Dim gAry() As Variant Dim sKipv As Long sKipv = 10 wSDataSet v dPickOut v, aAry(), gAry, sKipv rEsultWriteOutToWs aAry, gAry Erase v, aAry, gAry End Sub Private Sub wSDataSet(v() As Variant) Dim r As Range With Worksheets("生徒情報") Set r = .Cells(1).CurrentRegion Set r = r.Offset(1).Resize(r.Rows.Count - 1) v = r.Value End With End Sub Private Sub dPickOut(v() As Variant, aAry() As Variant, gAry() As Variant, ByVal skv As Long) Dim aFlg As Boolean Dim i As Long Dim j As Long Dim var As Variant Dim a As Long Dim g As Long Dim cnt As Long Dim 証書番号 As Long Dim 卒業年 As String Dim 最高学年 As Long Dim 名前 As String Dim 生年月日 As Variant 証書番号 = 1 卒業年 = Format(Now, "ggge年") 最高学年 = Worksheets("データベース").Cells(11, 2).Value If skv < 1 Then Exit Sub aFlg = True For i = 1 To UBound(v, 1) If v(i, 3) = 最高学年 Then cnt = cnt + 1 'MsgBox i
名前 = v(i, 17) 生年月日 = Format(v(i, 22), "ggge年m月d日") If v(i, 19) <> "" Then 名前 = v(i, 19) var = Array("第" & 証書番号 & "号", 卒業年 & vbCrLf & "3月31日", 名前, 生年月日 & "生") dPickOut_Sub_DivWrightData var, aFlg, aAry, gAry, a, g Erase var If cnt Mod skv = 0 Then dPickOut_Sub_SetFlg aFlg End If 証書番号 = 証書番号 + 1 End If
If cnt Mod 32 = 0 Then DoEvents Next End Sub Private Sub dPickOut_Sub_DivWrightData(ByVal var As Variant, _ ByVal aFlg As Boolean, _ ByRef aAry() As Variant, _ ByRef gAry() As Variant, _ ByRef a As Long, _ ByRef g As Long) If aFlg Then ReDim Preserve aAry(a) aAry(a) = var a = a + 1 Else ReDim Preserve gAry(g) gAry(g) = var g = g + 1 End If End Sub Private Sub dPickOut_Sub_SetFlg(ByRef aFlg As Boolean) If aFlg Then aFlg = False Else aFlg = True End If End Sub Private Sub rEsultWriteOutToWs(aAry(), gAry()) ReDim w1(1 To UBound(aAry) + 1, 1 To 5) ReDim w2(1 To UBound(gAry) + 1, 1 To 5) Dim i As Long Dim j As Long For i = LBound(aAry) To UBound(aAry) For j = LBound(aAry(i)) To UBound(aAry(i)) w1(i + 1, j + 1) = aAry(i)(j) Next Next For i = LBound(gAry) To UBound(gAry) For j = LBound(gAry(i)) To UBound(gAry(i)) w2(i + 1, j + 1) = gAry(i)(j) Next Next With Worksheets("授与台帳") .UsedRange.Clear .Cells(6, 1).Resize(UBound(w1, 1), UBound(w1, 2)) = w1 .Cells(6, 7).Resize(UBound(w2, 1), UBound(w2, 2)) = w2 End With Erase w1, w2 End Sub 大変な間違いを致しておりましたのでコードを修正致しました 14:35 頃 ^^;。。。m(__)mm(__)mm(__)m (隠居Z) 2023/01/27(金) 13:07:27
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.