へっぽこヘタレシステム管理者の管理人です。
国が推進する自治体システムの標準化・共通化で・・・
管理人が勤務する自治体では、標準化システムに移行したのですが、
新システムに四苦八苦しております。
さらに、先日の衆議院議員解散総選挙・・・
新システムで入場券の印刷や期日前投票ができるのか？？？
と不安に思いながらなんとか乗り切ったのですが、
その時の忘備録として、
期日前投票では、毎日入場券とシステムから出力されるデータを読みあわせするのですが、
まいかい、出力されるCSVを印刷できるフォーマットに形成するのが、
面倒だったので、一括処理できるマクロを作成したので、コードを公開しておきます。
需要はあるのか分かりませんが・・・
使い方は簡単です。
上の図のエクセルを真似て【MENU】シートを作成してください。
それから、空のシートですが、
【全件データ】・【印刷用データ】
を作成します。
COKAS-R for Govからのデータ出力は次のとおりです。
- 業務 → 04 選挙
- 処理 → 08 投票事務関連処理
- 処理 → 1 投票事務処理簿一覧作成処理
- CSVが出力される
あとは、マクロを張り付けて実行するだけです。
これで、読み合わせができる帳票が簡単に印刷できるようになります。
ブログランキングにご協力ください！
２０万件の選挙人のデータだと、
処理時間は、パソコンスペックにもよりますが、
約5分といったところです。
長い文字列を置換して短縮することもできます。
例えば【衆議（小選挙区）選挙 → 小】といった具合です。
列の幅を取られると印刷が厳しくなるので必須ですね。
残したい列や消した列があったら、適当にコードをいじくってください。
Sub Macro1()
'
' Macro1 Macro
'
Application.ScreenUpdating = False
Application.DisplayStatusBar = True
'全件データを印刷用データにコピー
Sheets("印刷用データ").Select
Cells.Select
Selection.Delete
Sheets("全件データ").Select
Cells.Select
Selection.Copy
Range("A1").Select
Sheets("印刷用データ").Select
Cells.Select
ActiveSheet.Paste
Range("A1").Select
'ソート
Dim r As Range
Set r = Range("A1").CurrentRegion ' 表全体を選択
' 優先順位の低い順に実行すると、最終的に一番上が優先されます
r.Sort Key1:=Range("D1"), Order1:=xlAscending, Header:=xlYes ' 3番目
r.Sort Key1:=Range("H1"), Order1:=xlAscending, Header:=xlYes ' 2番目
r.Sort Key1:=Range("BY1"), Order1:=xlAscending, Header:=xlYes ' 1番目（最優先）
'タイトル行追加
Cells(1, 94) = "選挙１"
Cells(1, 95) = "選挙２"
Cells(1, 96) = "選挙３"
Cells(1, 97) = "選挙４"
Cells(1, 98) = "選挙５"
Cells(1, 99) = "備考"
'最大行を取得
Dim maxrow As Long
maxrow = Cells(Rows.Count, 1).End(xlUp).Row
'投票を列にコピーする
Dim sgyou As Long '選挙人の投票の先頭行
sgyou = 1
Dim i As Long
i = 1 '選挙人での行数
Do While sgyou <= maxrow
Do
If Cells(sgyou, 8) = Cells(sgyou + i, 8) Then
Cells(sgyou, 94 + i) = Cells(sgyou + i, 5)
i = i + 1
Else
Cells(sgyou + i, 94) = Cells(sgyou + i, 5)
Exit Do
End If
Loop
sgyou = sgyou + i
i = 1
Application.StatusBar = "選挙種別貼付：" & sgyou & "件/" & maxrow & "件"
Loop
'置換
Dim maeword As String
Dim atoword As String
For j = 20 To 29
maeword = Worksheets("MENU").Cells(j, 3)
atoword = Worksheets("MENU").Cells(j, 4)
Range("BJ:BJ,BL:BL,CP:CU").Replace _
What:=maeword, _
Replacement:=atoword, _
LookAt:=xlPart, _
MatchCase:=False
Next
'投票区分を結像
For s = 2 To maxrow
Cells(s, 99) = Cells(s, 94) & " " & Cells(s, 95) & " " & Cells(s, 96) & " " & Cells(s, 97) & " " & Cells(s, 98)
Application.StatusBar = "選挙種別テキスト連結：" & s & "件/" & maxrow & "件"
Next
'不要列削除
Columns("A:M").Delete
Columns("D:U").Delete
Columns("F:H").Delete
Columns("G:H").Delete
Columns("I:Y").Delete
Columns("J").Delete
Columns("K").Delete
Columns("L:U").Delete
Columns("M:AB").Delete
Columns("M:Q").Delete
'列幅調整
Columns("A:C").ColumnWidth = 3
Columns("D").ColumnWidth = 15
Columns("E").ColumnWidth = 15
Columns("F").ColumnWidth = 5
Columns("G").ColumnWidth = 10
Columns("H").ColumnWidth = 15
Columns("I:J").ColumnWidth = 5
Columns("K").ColumnWidth = 15
'A列を挿入して連番を付ける
Columns("A").Insert
Cells(1, 1) = "NO"
Columns("A").ColumnWidth = 5
'連番挿入
Dim rowno As Long
rowno = 1
For k = 2 To maxrow
If Application.Trim(Cells(k, 14)) <> "" Then
Cells(k, 1) = rowno
rowno = rowno + 1
Else
End If
Application.StatusBar = "連番挿入：" & k & "件/" & maxrow & "件"
Next
'全体を縮小表示
With ActiveSheet.Cells
.WrapText = False ' 折り返して表示を解除（これが必要）
.ShrinkToFit = True ' 縮小して全体を表示を設定
End With
'印刷設定
With ActiveSheet.PageSetup
' 1行目をタイトル行に設定
.PrintTitleRows = "$1:$1"
' 用紙サイズをA4に設定
.PaperSize = xlPaperA4
' 向きを横にする場合（縦なら xlPortrait）
.Orientation = xlPortrait
' 横幅を1ページに収める（縦は自動）
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = False
'余白を「狭く」設定 (単位：センチメートル)
' Excelの標準的な「狭い」の設定値です
.TopMargin = Application.CentimetersToPoints(1.9) ' 上
.BottomMargin = Application.CentimetersToPoints(1.9) ' 下
.LeftMargin = Application.CentimetersToPoints(0.6) ' 左
.RightMargin = Application.CentimetersToPoints(0.6) ' 右
.HeaderMargin = Application.CentimetersToPoints(0.8) ' ヘッダー
.FooterMargin = Application.CentimetersToPoints(0.8) ' フッター
'水平方向の中央に配置（お好みで）
.CenterHorizontally = True
' フッターの中央に「1 / 5 ページ」のように表示する設定
' &P は現在のページ番号、&N は総ページ数です
.CenterFooter = "&P / &N ページ"
End With
'罫線引く
With Range(Cells(1, 1), Cells(maxrow, 14)).Borders
.LineStyle = xlContinuous ' 実線
.Weight = xlThin ' 細線
.ColorIndex = xlAutomatic ' 自動（黒）
End With
'A列で昇順でフィルタ実行
Range("A1").CurrentRegion.Sort _
Key1:=Range("A1"), _
Order1:=xlAscending, _
Header:=xlYes '
'A列の最大業を取得
Dim maxrow2 As Long
maxrow2 = Cells(Rows.Count, 1).End(xlUp).Row
Application.StatusBar = "最終最大業：" & maxrow2 & "件"
'ソート後の空白行を削除
Rows(maxrow2 + 1 & ":" & maxrow).Delete
MsgBox "処理が終了しました"
End Sub
これも需要があるのかどうか分かりませんが・・・
とりあえず、ネタがないので、ネタにします。
コメント