[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『卒業者台帳を作成したいです。』(るっく)
「生徒情報シート」から情報を取得して、「授与台帳シート」に貼り付けたいです。
その際、下の図のように、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.