企業、学校、個人。それぞれのシーンに於いて一定の需要があるのが「グループ分け」。人の班分けだけでなく、物品のグルーピングなどに於いて一定の条件の元グループ分けをする作業は、人間が行うと高確率で失敗します。
しかし、自分の需要にあったグループ分けプログラムは自分で作るしかありません。そこで今回研修会参加者を一定条件に基づいて班分けするというプログラムを作成しました。
難易度：
リンク
目次
今回使用するファイル
- グループ分けプログラム – Access2016で作成（64bit）
- 日程表テンプレート – 上記のプログラムにも同梱のexcelシート
※日程表テンプレートに参加者情報を記述して、Access側にインポートする仕組みになっています。グループ分けはAccess側で行わせます。
事前準備と条件
プログラムの準備
このプログラムは以下の参照設定を利用しています。今どきの環境で追加しなければならないというものは無いと思いますので、通常は特に何もする必要はありません（自前で構築する場合を除く）
- Microsoft Office 15.0 Object Library – リボンの構築で使用しています。
- Microsoft Scripting Runtime – ファイルの有無など様々なシーンで利用しています。
- ActiveX Data Object 2.8 Library – Excelデータの書き出し時に今回利用しています。
また、暗号化ZIP形式でのバックアップ・復元の為に、7-zip64.dllを利用しています（ファイルに同梱）。
図：ライブラリの参照が必要
日程表の準備
日程表テンプレートにデータの追記が必要です。本プログラムはこの日程表を取り込んで、グループ分けをするプログラムという形にしているため、事前にデータの準備が必要になります。
データはテーブル形式になっており、今回利用する列は以下の通り。
- 会社No（数値）
- 会社名（文字列）
- 部署（文字列）
- 業種（文字列）
- 姓_漢字（文字列）
- 名_漢字（文字列）
- 姓_全角カナ（文字列）
- 名_全角カナ（文字列）
- 年齢（数値）
- 性別（文字列） – 男 or 女
各種コードシートは、メインの受講者リストの入力を助けるためのものなので、特に整備はせずとも良いですが、データの入力規則やvlookup関数での参照などで利用すると良いでしょう。
グループ分け条件
今回のプログラムでは振り分ける条件を固定ではなく、いくつかはオプションで選べるように作成しています。固定の条件としては人数チェックと男女比チェックは必ず実行するようにしています（つまり、1チーム指定の人数を超えているか？男女比が約半分になってるかどうか？）。
- リボンのグループ分け⇒アプリの設定を開く
- アプリの設定ダイアログ内の「アプリの設定」タブを開く
- 振り分けオプションでさらに振り分け条件を加えたい場合にはチェックを入れる
- グループ人数は、1チーム当たりの人数です。日程表参加者をこの数値で割った値がグループの数になります。
- 年齢構成チェックは、全体の中央値（平均値ではない）に近くなるように、振り分けチーム内の年齢構成を考慮して、チームに加える設定です。
- 同姓チェックは、同じ姓を持つものはなるべく一緒にしないようにする為の設定です。
- 同企業チェックは、複数会社参加の振り分けをする際に、同じチーム内に同じ会社の人間を一緒にしない為の設定です。
- 同業種チェックは、複数会社参加の振り分けをする際に、同じチーム内に同じ業種の人間を一緒にしない為の設定です。
- 同部署チェックは、同じチーム内に同じ部署の人間が一緒にしない為の設定です。
- 年齢構成チェックをオンにすると、「なるべく近い歳」というオプションが使えます。このオプションは追加時のチーム内最小年齢の上下2歳までをチームに追加可とするという条件に変更する為のものです。
- 保存を押すとsettingテーブルにオプション設定が保存されます。
振り分けには乱数を利用し、グループ数分のコードが割り振られるようになっていますが、条件によっては必ずしも条件通りの振り分けができるとは限りません。その場合、あぶれた人は再度、人数チェックと男女比チェックだけでどこかのチームにねじ込むようにプログラムされています。条件にあぶれた人をねじ込んでるので、条件通りになっていないチームも発生します。
但しこれでもあぶれるケースがあります。この場合振り分け失敗となりますが、乱数を使ってるので、再度振り分け実行を行えばうまくいく事もあります。
使い方
使い方自体は非常に単純です。
- 受講者リストのインポートをクリックし、用意した日程表テンプレートを読み込ませてデータを取り込みます（洗い替えなので、新しいデータを取り込むと古いデータは削除されます）
- グループ分け実行を行うと。アプリの設定にてセットした条件に基づいて判定し、チーム割を行います。
- グループ分けが完了するとグループ分け結果フォームが表示され、チーム内平均年齢や人数、それぞれの人間の値が表示されます。
- グループ分け出力をクリックすると、指定の場所に受講者リストとして分けた結果をソートしたデータをExcel形式で出力してくれます。
ZIPバックアップを活用すると、セットした条件やその時の結果などをキープしておけ、復元で元に戻せるようになっています。いくつか試してみて納得の行くパターンになったら、出力してみると良いでしょう。
ソースコード
グループ分けを実行するコード
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 |
'グループ分けを行うメインルーチン Public Function groupin() '変数の宣言 Dim alluser As Integer '全ユーザ数 Dim mbrlimit As Integer '1チームあたり人数 Dim grpcount As Integer 'グループ数 Dim avgage As Double '全ユーザ平均年齢 Dim insflg As Boolean '追加していいよフラグ Dim i As Long Dim cnt As Long mbrlimit = DLookup("値", "setting", "ID=1") 'グループ人数設定を取得 cnt = 1 Dim result As Variant Dim checkernum As Boolean Dim empid As Integer Dim danjolim As Integer Dim seibetsu As String Dim breaker As Integer breaker = 1 Dim targetage As Integer Dim firstname As String Dim compid As Integer Dim nejiko As Integer Dim gyouname As String Dim busyoname As String nejiko = 0 Dim ans As Integer '該当レコードが処理済みになってる場合問い合わせをする result = MsgBox("取り込んだリストを元にグループ分けを実行しますか？", vbYesNo + vbDefaultButton2 + vbExclamation) If result = vbYes Then 'インポート処理を続行する Else 'メッセージを表示 MsgBox "データの更新をキャンセルしました。" '終了処理 Exit Function End If 'DB接続用変数 Dim db As DAO.Database Dim rst As DAO.Recordset Dim rse As DAO.Recordset Dim rso As DAO.Recordset Dim strSQL As Variant Set db = CurrentDb 'テーブルデータをクリアする strSQL = "DELETE * FROM グループ" db.Execute strSQL strSQL = "DELETE * FROM チーム" db.Execute strSQL 'レコードセットをセットする Set rst = db.OpenRecordset("受講者リストソート") Set rse = db.OpenRecordset("グループ") Set rso = db.OpenRecordset("チーム") 'グループ数と平均年齢を取得する alluser = DCount("ID", "受講者リスト") grpcount = RoundUp(alluser / mbrlimit, 0) '小数点以下桁上げ avgage = CInt(DLookup("Median", "中央値")) '全平均年齢 danjolim = RoundUp(mbrlimit / 2, 0) 'グループテーブルに連番でグループを生成 For i = 1 To grpcount With rse .AddNew !グループナンバー = cnt .Update End With 'カウンタを回す cnt = cnt + 1 Next i '条件判定して受講者IDをチームテーブルに追加する Dim teamavg As Variant Dim options As Variant Dim beforeflg As Integer Dim tempavgage As Integer beforeflg = 0 '振り分けオプションの取得 Dim nencheck As Variant Dim doucheck As Variant Dim comcheck As Variant Dim induscheck As Variant Dim bucheck As Variant Dim naruage As Variant nencheck = DLookup("値", "setting", "ID=2") doucheck = DLookup("値", "setting", "ID=3") comcheck = DLookup("値", "setting", "ID=4") induscheck = DLookup("値", "setting", "ID=5") bucheck = DLookup("値", "setting", "ID=6") naruage = DLookup("値", "setting", "ID=7") Do Until rst.EOF 'カウンタ・フラグ初期化 breaker = 1 insflg = False '受講者IDを取得する empid = rst("ID") '性別を取得する seibetsu = rst("性別") seibetsu = Replace(seibetsu, "性", "") '年齢を取得する targetage = rst("年齢") '名字を取得する firstname = rst("姓_漢字") '会社Noを取得する compid = rst("会社No") '業種名を取得する gyouname = rst("業種") '部署名を取得する If IsNull(rst("部署")) Then busyoname = "" Else busyoname = rst("部署") End If '乱数初期化 Randomize Do Until insflg = True '変数初期化 beforeflg = 0 'ランダムなcntを生成 cnt = Int(grpcount * Rnd + 1) 'カウンタが既定値を超えていた場合にはプログラムを終了する（無限ループ防止） If breaker > grpcount Then Exit Do End If '人数がリミットに達していなければtrue checkernum = checkman(mbrlimit, cnt) If checkernum = True Then '男女比的にNGかどうか？ checkernum = danjocheck(danjolim, cnt, seibetsu) If checkernum = True Then '年齢チェック開始 options = nencheck If options = -1 Then 'なるべく近い歳オプションの有無 options = naruage If options = -1 Then 'チームの最小年齢を算出 teamavg = DMin("年齢", "チーム", "グループナンバー=" & cnt) If IsNull(teamavg) Then 'フラグを立てる beforeflg = beforeflg + 1 Else '最小年齢の前後2歳までを対象とする tempavgage = targetage - teamavg 'マイナス値の場合はプラス値に変える If tempavgage < 0 Then tempavgage = tempavgage * -1 End If If tempavgage > 2 Then '年齢を2歳超えてるのでNG Else 'OKなのでフラグを立てる beforeflg = beforeflg + 1 End If End If Else '従来の平均年齢に沿った振り分けを実行 '対象のチームの平均年齢を出す teamavg = DAvg("年齢", "チーム", "グループナンバー=" & cnt) If IsNull(teamavg) Then teamavg = 0 End If '年齢が対象となるものかどうか判定 checkernum = agecheck(avgage, CDbl(teamavg), targetage) If checkernum = True Then beforeflg = beforeflg + 1 End If End If Else beforeflg = beforeflg + 1 End If '同部署チェック開始 options = bucheck If options = -1 Then '年齢が対象となるものかどうか判定 checkernum = bumoncheck(busyoname, cnt) If checkernum = True Then beforeflg = beforeflg + 1 End If Else beforeflg = beforeflg + 1 End If '同企業チェック開始 options = comcheck If options = -1 Then checkernum = compcheck(compid, cnt) If checkernum = True Then beforeflg = beforeflg + 1 End If Else beforeflg = beforeflg + 1 End If '同業種チェック開始 options = induscheck If options = -1 Then checkernum = gyoucheck(gyouname, cnt) If checkernum = True Then beforeflg = beforeflg + 1 End If Else beforeflg = beforeflg + 1 End If '同姓チェック開始 options = doucheck If options = -1 Then checkernum = firstcheck(firstname, cnt) If checkernum = True Then beforeflg = beforeflg + 1 End If Else beforeflg = beforeflg + 1 End If 'beforeflgの値が5ならば追加する If beforeflg = 5 Then 'チームにメンバーを追加する With rso .AddNew !グループナンバー = cnt !受講者ID = empid !性別 = seibetsu !年齢 = targetage !姓_漢字 = firstname !会社No = compid !業種 = gyouname !部署 = busyoname .Update End With 'フラグを立てる insflg = True End If End If End If 'breakerカウントをアップ breaker = breaker + 1 Loop 'この時点でinsflgがfalseの場合どこかのチームにねじ込む（ファジー対応） If insflg = False Then 'ねじこみカウント追加 nejiko = nejiko + 1 '変数初期化 breaker = 1 '乱数初期化 Randomize Do Until insflg = True 'ランダムなcntを生成 cnt = Int(grpcount * Rnd + 1) 'カウンタが既定値を超えていた場合にはプログラムを終了する（無限ループ防止） If breaker > grpcount Then Exit Do End If '人数がリミットに達しているかチェック checkernum = checkman(mbrlimit, cnt) If checkernum = True Then '男女比的にNGかどうか？チェック checkernum = danjocheck(danjolim, cnt, seibetsu) If checkernum = True Then 'チームにメンバーをねじこむ With rso .AddNew !グループナンバー = cnt !受講者ID = empid !性別 = seibetsu !年齢 = targetage !姓_漢字 = firstname !会社No = compid !業種 = gyouname !部署 = busyoname .Update End With 'フラグを立てる insflg = True End If End If 'breakerをカウントアップ breaker = breaker + 1 Loop '最終チェック If insflg = False Then ans = MsgBox("条件厳しくて、だめだったっぽい。。", vbOKOnly + vbCritical, "失敗！！") Exit Function End If End If '次のレコードへ移動する rst.MoveNext Loop 'ねじ込みカウント表示 If nejiko = 0 Then Else ans = MsgBox(nejiko & "件ねじこみました。", vbOKOnly + vbInformation, "ネジ込み件数") End If '終了処理 ans = MsgBox("チーム分けが完了しました", vbOKOnly + vbInformation, "処理完了") DoCmd.OpenForm "グループ分け結果", acNormal, , , acFormEdit, acWindowNormal rst.Close rse.Close rso.Close Set rso = Nothing Set rse = Nothing Set rst = Nothing Set db = Nothing End Function '人数チェックをする関数 Public Function checkman(ByVal limit As Integer, ByVal teamnum As Integer) As Boolean '対象のteamnumの現在の枠数をチェック Dim check As Variant check = DLookup("受講者IDのカウント", "人数カウント", "グループナンバー=" & teamnum) 'メンバー数がリミットに達しているかどうか If check >= limit Then checkman = False Else checkman = True End If End Function '男女比をチェックする関数 Public Function danjocheck(ByVal limit As Integer, ByVal teamnum As Integer, ByVal sei As String) As Boolean '対象のteamnumの現在のhanseiの値がlimitに達しているかチェック Dim check As Variant check = DCount("ID", "チーム", "性別='" & sei & "' AND グループナンバー=" & teamnum) If check > limit - 1 Then 'リミット超えてるので追加だめ danjocheck = False Else 'リミット達していないのでOK danjocheck = True End If End Function '年齢平均チェックをする関数 Public Function agecheck(ByVal allavg As Double, ByVal teamavg As Double, ByVal targetage As Integer) As Boolean '変数の宣言 Dim hantei As Boolean '全平均とチーム平均の比較 If allavg >= teamavg Then 'ターゲットとチーム平均を比較（高い方を入れる） If targetage >= teamavg Then hantei = True Else hantei = False End If Else 'ターゲットとチーム平均の比較（低い方を入れる） If targetage >= teamavg Then hantei = False Else hantei = True End If End If '判定結果を返す agecheck = hantei End Function '同じ姓の人間がいるかどうかチェックする関数 Public Function firstcheck(ByVal firstname As String, ByVal teamnum As Integer) As Boolean '対象のteamnumに於いて、同姓の人間が何名いるか？ Dim check As Variant check = DCount("ID", "チーム", "姓_漢字='" & firstname & "' AND グループナンバー=" & teamnum) 'カウントが0ならばtrue If check = 0 Then firstcheck = True Else firstcheck = False End If End Function '会社名の重複があるかどうかチェックする関数 Public Function compcheck(ByVal compid As Integer, ByVal teamnum As Integer) As Boolean '対象のteamnumの現在のhanseiの値がlimitに達しているかチェック Dim check As Variant check = DCount("ID", "チーム", "会社No=" & compid & " AND グループナンバー=" & teamnum) 'カウントが0ならばtrue If check = 0 Then compcheck = True Else compcheck = False End If End Function '同じ業種の重複があるかどうかをチェックする関数 Public Function gyoucheck(ByVal gyouname As String, ByVal teamnum As Integer) As Boolean '対象のteamnumに指定のgyounameが含まれている件数をチェック Dim check As Variant check = DCount("ID", "チーム", "業種='" & gyouname & "' AND グループナンバー=" & teamnum) 'カウントが0ならばtrue If check = 0 Then gyoucheck = True Else cgyoucheck = False End If End Function '部署名の重複があるかどうかをチェックする関数 Public Function bumoncheck(ByVal buname As String, ByVal teamnum As Integer) As Boolean '対象のteamnumに指定のgyounameが含まれている件数をチェック Dim check As Variant check = DCount("ID", "チーム", "部署='" & buname & "' AND グループナンバー=" & teamnum) 'カウントが0ならばtrue If check = 0 Then bumoncheck = True Else bumoncheck = False End If End Function |
- グループテーブルは振り分け後の振り分け結果の親テーブルです。チームテーブルがそれにぶら下がるサブテーブルとなります。
- 受講者リストソートはクエリです。人数が多い順に会社毎にソートしています（こうする事で振り分け成功率が上がります）
- グループ数は参加者総数÷1チーム当たり人数で算出。
- 平均年齢とありますが、実際には中央値を利用しています。振り分け時に、全体中央値よりチーム平均値が低い場合、高い場合、それぞれに於いて追加しようとしてる者の年齢を比較して追加するか？しないかを決定しています。
- 男女比の算出は全体から算出。1チーム当たり人数÷2で計算していますが、男女比が1:1ではないようなケースでは、ここの加工が必要になります。
- 対象者の追加可否のトライ回数はグループ数回分行う。この判定用にbreaker変数を用意してあり、breakerがリミットに達したら、ループを強制離脱します。
- チェック順序はより条件が厳しい重複可能性の高い項目から行っています（でないと、条件適合外が大量に発生してしまう）。
- 順番は、人数リミットチェック、男女比チェック、部署チェック、同部署チェック、同企業チェック、同業種チェック、同姓チェックの順に行っています。
- beforeflgに値を加算する事で通過とし、合計値がオプション項目の数の合計である5に達したらチームに加えるようにしています。
- あぶれた場合、2段階目として「人数リミット」「男女比」のチェックのみで通過とし、チームに強制振り分けをさせています。
- それでもNGの場合には「失敗」と看做し、プログラムは強制終了します。但し、Rnd関数によるランダムな生成なので、再度の実行や条件の緩和によって通過するようになるかもしれません。
実行結果をExcelシートに書き出すコード
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 |
'振り分け結果データをExcel Automationで出力する Public Function exportReport() Dim AppObj As Object 'Excel.Applicationオブジェクトの宣言 Dim WBObj As Object 'Excel.Workbookオブジェクトの宣言 Dim WsObj As Object 'Excel.WorkSheetオブジェクトの宣言 Dim WsObj2 As Object Dim FilePath As String Dim strFileName As Variant Dim dummyfile As String ’DB接続用の変数 Dim dbs As Database Dim strSQL As String Set dbs = CurrentDb 'コネクションを確立する Dim con As New ADODB.Connection Dim rec As New ADODB.Recordset Set con = CurrentProject.Connection 'デスクトップフォルダを取得 Dim dPath As String, WSH As Variant Set WSH = CreateObject("WScript.Shell") dPath = WSH.SpecialFolders("Desktop") & "\" '仮のファイル名を生成する dummyfile = dPath & "受講者管理シート" '名前をつけて保存ダイアログを表示 strFileName = GetFileName(False, 'MicrosoftExcel ブック (*.xlsx)|*.xlsx', '', dummyfile & '.xlsx') '選択結果を評価 If strFileName = 0 Then 'キャンセルボタンが押されたときの処理を記述 MsgBox "キャンセルされました。" Exit Function End If 'テンプレファイルを指定する FilePath = CurrentProject.Path & "\export.xlsx" 'ファイルを複製する（ダイアログ使用） FileCopy FilePath, strFileName 'ファイルを開く Set AppObj = CreateObject("Excel.Application") '実行時バインディング Set WBObj = AppObj.Workbooks.Open(strFileName) 'ワークブックを開く Set WsObj = WBObj.Worksheets("事務局用会社順") 'excel画面の更新をオフにする AppObj.ScreenUpdating = False '砂時計のマウスポインタ DoCmd.Hourglass True AppObj.Visible = True 'Excelアプリケーションを表示する AppObj.Calculation = xlManual '再計算を停止する 'ワークシートへの処理 'Excelにエクスポートしたいテーブルのデータを取得 rec.Open "事務局用会社順", con WsObj.Range("a2").CopyFromRecordset rec rec.Close Set WsObj = WBObj.Worksheets("事務局用50音順") rec.Open "事務局用50音順", con WsObj.Range("a2").CopyFromRecordset rec rec.Close Set WsObj = WBObj.Worksheets("事務局用G順") rec.Open "事務局用G順", con WsObj.Range("a2").CopyFromRecordset rec rec.Close Set WsObj = WBObj.Worksheets("受講者用G順") rec.Open "受講者用G順", con WsObj.Range("a2").CopyFromRecordset rec rec.Close '再計算に戻す AppObj.Calculation = xlAutomatic AppObj.ScreenUpdating = True '砂時計のマウスポインタ DoCmd.Hourglass False 'Excelを保存して閉じる WBObj.Save 'ワークブックを保存する WBObj.Close 'ワークブックを閉じる AppObj.Quit '終了処理 Set AppObj = Nothing Set WBObj = Nothing Set WsObj = Nothing Set WsObj2 = Nothing 'メッセージ表示 MsgBox "受講者管理シートデータの作成が完了しました。" End Function Function GetFileName(OpenOrSaveFlg As Boolean, strFilter As String, _ strTitle As String, strDefaultPath As String) As String Dim returnValue As Integer Dim strFilePath As String strFilePath = strDefaultPath If strFilter = "" Then strFilter = "全てのファイル (*.*)|*.*" End If WizHook.key = 51488399 'WIZHOOK有効 returnValue = WizHook.GetFileName( _ 0, "", strTitle, "", strFilePath, "", _ strFilter, _ 0, 0, 0, OpenOrSaveFlg _ ) WizHook.key = 0 ' WizHook 無効 If returnValue = 0 Then GetFileName = strFilePath Else GetFileName = 0 End If End Function '全角半角カナ変換 Public Function kanahen(kanaword As String) As String kanahen = StrConv(kanaword, vbWide) End Function 'へんなスペース除去 Public Function cutspace(words As String) As String Dim temp As String '全角半角のスペース除去 temp = Replace(words, " ", "") temp = Replace(words, " ", "") cutspace = temp End Function |
- デスクトップフォルダを初期値として、export.xlsxファイルをコピーし、そこに出力します。
- チーム内容をソートしたクエリをそれぞれ、CopyFromRecordsetメソッドで指定のシートに出力します。
- GetFileName関数はファイルの選択用ダイアログを出すための関数です。
- 時々指定の列の文字に半角全角混在してるケースがあるので、kanahenにて全角カナに統一しています。
- 時々指定の列の文字にスペースが混在してるケースがあるので、cutspaceにてスペースは除去しています。
- ADOとCopyFromRecordsetがあれば同様のデータ出力は可能なので、Excel単体でも出力系は完結は可能といえば可能です。
関連リンク
- CopyFromRecordsetでRecordsetの中身をワークシートに一括出力
- [ファイルを開く]ダイアログボックスを表示する（GetOpenFilenameメソッド）
- VBAで乱数を発生させる（Rnd、Randomize）
