Private Sub btnMakeExcel_Click()
Dim rs As New ADODB.Recordset 'ADOのレコードセット
Dim objEXCEL As Object 'Excel参照用
Dim nYLINE As Integer '行セット位置
Dim nXLINE As Integer '列セット位置
Dim nRCNT As Integer 'レコードカウンタ
Dim strWORK As String 'ワーク変数
'Excelを起動する、オブジェクトの作成
Set objEXCEL = CreateObject("Excel.Application") 'オブジェクトの作成
objEXCEL.Visible = True 'Excelを見えるようにする
'新規のブックを追加する
objEXCEL.Workbooks.Add 'Excelのブックを作成
'Excelのシートを追加、シート名を変更する
objEXCEL.Sheets.Add 'シートを追加する
objEXCEL.ActiveSheet.Name = "DATA" 'シート名をDATAにする
'列幅は、縦なので、ここ、頭で定義する
For nXLINE = 1 To 9 Step 3
objEXCEL.Columns(nXLINE).ColumnWidth = 8.5
objEXCEL.Columns(nXLINE + 1).ColumnWidth = 8.5
objEXCEL.Columns(nXLINE + 2).ColumnWidth = 1.8
Next nXLINE
'レコードセットを開く(Q_YUBIN_5)
rs.Open "Q_YUBIN5", CurrentProject.Connection, _
adOpenKeyset, adLockOptimistic
'カウンタの初期化 スタート位置のセット
nYLINE = 1 '１行目だよ
nXLINE = 1 '１列目（A列）だよ
'見出しをセットする
objEXCEL.Cells(nYLINE, nXLINE) = "郵便番号"
objEXCEL.Cells(nYLINE, nXLINE + 1) = "件数"
'罫線を引く(見出しの位置から＋１０行分)
Call make_Border(objEXCEL.Range(objEXCEL.Cells(nYLINE, nXLINE), _
objEXCEL.Cells(nYLINE + 10, nXLINE + 1)))
'行の高さを調整する
objEXCEL.Rows(nYLINE).RowHeight = 25 '見出しの高さを25へ
strWORK = Trim(nYLINE + 1) & ":" & Trim(nYLINE + 10) '10行分の範囲文字列
objEXCEL.Rows(strWORK).RowHeight = 16 'データ高さを16へ
nYLINE = nYLINE + 1 '見出し分行数が増えます
nRCNT = 1 '見出し表示後は１レコード目だよ
'レコードセットからExcelへデータをセットする
'ループ処理
While rs.EOF = False 'いつものEOFが偽の間
'データをセットする(Accessから転記)
objEXCEL.Cells(nYLINE, nXLINE) = rs("変換後郵便番号").Value
objEXCEL.Cells(nYLINE, nXLINE + 1) = rs("変換後郵便番号のカウント").Value
'セルの色を変える
objEXCEL.Cells(nYLINE, nXLINE).Interior.ColorIndex = 33 'スカイブルー
objEXCEL.Cells(nYLINE, nXLINE + 1).Interior.ColorIndex = 33
'次を読む And カウンタを移動する
rs.MoveNext '次のレコードに移動しないと、とんでもないことに(笑)
nRCNT = nRCNT + 1 '処理レコード数を増やす
If nRCNT > 10 Then '処理したレコードが10を越えた(次の列)
nXLINE = nXLINE + 3 '次の列へカウンタを移動
If nXLINE > 9 Then '列が越えた？
nXLINE = 1 '1列目（Ａ列）に戻す
nYLINE = nYLINE + 2 '空白行にしたいのでセット位置を＋２する
Else
nYLINE = nYLINE - 10 '列が変わったので行カウンタをマイナスする
End If
'見出しの表示
objEXCEL.Cells(nYLINE, nXLINE) = "郵便番号"
objEXCEL.Cells(nYLINE, nXLINE + 1) = "件数"
'罫線を引く(見出しの位置から＋１０行分)
Call make_Border(objEXCEL.Range(objEXCEL.Cells(nYLINE, nXLINE), _
objEXCEL.Cells(nYLINE + 10, nXLINE + 1)))
'行の高さを調整する
objEXCEL.Rows(nYLINE).RowHeight = 25 '見出しの高さを25へ
strWORK = Trim(nYLINE + 1) & ":" & Trim(nYLINE + 10) '範囲文字列を作成
objEXCEL.Rows(strWORK).RowHeight = 16 'データ高さを16へ
nYLINE = nYLINE + 1 '見出し表示分行数が増えます
nRCNT = 1 '見出し表示後は１レコード目だよ
Else '
nYLINE = nYLINE + 1 '次の行へセット位置を移動
End If
Wend
'通常は、ここでExcelを保存するんだけど、今回は開きっぱなしの手抜き
rs.Close '開いたら閉じろ、ドアを開けたら閉めるってしつけられたでしょ(笑)
Set rs = Nothing '変数も後始末しますか。使った器はキレイにしろって?
End Sub |
Private Sub make_Border(objXY As Object)
'罫線用のExcel定数(参照設定している場合は、必要無し)
Const xlEdgeLeft = &H7
Const xlEdgeRight = &HA
Const xlEdgeTop = &H8
Const xlEdgeBottom = &H9
Const xlInsideVertical = &HB
Const xlInsideHorizontal = &HC
Const xlContinuous = &H1
Const xlThin = &H2
Const xlAutomatic = &HFFFFEFF7
Dim n As Integer
'配列に代入する
Dim styleBOX As Variant
styleBOX = Array(xlEdgeLeft, xlEdgeRight, xlEdgeTop _
, xlEdgeBottom, xlInsideVertical, xlInsideHorizontal)
For n = 0 To 5 '各ラインに対して、値をセットする
With objXY.Borders(styleBOX(n))
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
Next n
End Sub |
↑行った操作
記録で作られたマクロは、こんな感じです。
↑実行結果です、なんとかここまでできました。
部分的に考えると、なんとかなりそうですね。
組み込んだ、長いセットのソースは、下記のような感じです。