#「Excelだけで差し込み印刷」から「年賀状印刷」へ発展させる。
年賀状プレビュー
##差出人の選択は、プルダウンのリストに空白を表示しない
宛先 住所録のサンプルはMSから頂戴しました。
差出人
##プルダウンリストに空白を表示しない
入力規則設定で空白を除く設定をする
=OFFSET(差出人!$A$3,,,COUNTA(差出人!$A:$A))
##漢字をカタカナにする
キラキラＮＡＭＥはむりなようです。
=PHONETIC([@姓])&" "&PHONETIC([@名])
##郵便番号から住所変換 その１ Web版(Excel標準機能 QueryTables.Add)
上は、Excelマクロで取得した結果、下はWebサイトの取得結果を手作業で貼り付けた
Web検索結果の表部分を取得して、セルに貼り付ける事ができる。
マクロ記録で 「データ → 外部データの取り込み → Webクエリ」で例のマクロと同じ様なものが出力されるが、対象は表のみのようだ。
With ActiveSheet.QueryTables.Add(Connection:= _
"URL;http://www.post.japanpost.jp/cgi-zip/zipcode.php?zip=671-1234" & , _
Destination:=Range("A4"))
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = False
.RefreshStyle = xlOverwriteCells ' 前のセルデータを上書きする。
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = False
.RefreshPeriod = 0
.WebSelectionType = xlSpecifiedTables
.WebFormatting = xlWebFormattingNone
.WebTables = "2"
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = False
.WebDisableRedirections = False
.Refresh BackgroundQuery:=False
.WebSelectionType = xlAllTables 'TABLEを取得
.Refresh 'Activeでないと表示更新されない
' Destination:=Range("A4")に結果が保存される
' 保存された結果から住所を取り出すとかの処理はここに書く
.Delete '名前の定義が残ってしまうのでここで削除
End With
##郵便番号から住所変換 その２ csvファイル版
郵便番号データは日本郵便サイトからダウンロードする。
全国版(11.7MB)CSVを検索に使う。
###Schema.iniを使ってみる。
Schema.iniの解説こちら
これがあると、Headerの無いCSVも列名を使って処理できるし、csvファイルと同じディレクトに置いておけば、勝手に使ってくれる。
更新作業も郵便番号CSVをDownLoadして解凍するだけ。
複数のＰＣから使いたい場合は、共有ディレクトに置けば良い。
[KEN_ALL.CSV]
ColNameHeader=True
CharacterSet=ANSI
Format=Delimited(,)
Col1=CODE1 Char Width 007
Col2=ZIP_OLD Char Width 005
Col3=ZIPCODE Char Width 007
Col4=KEN_KANA Char Width 050
Col5=SHI_KANA Char Width 050
Col6=CHO_KANA Char Width 100
Col7=KEN_KANJI Char Width 050
Col8=SHI_KANJI Char Width 050
Col9=CHO_KANJI Char Width 100
Col10=FLG1 Char Width 001
Col11=FLG2 Char Width 001
Col12=FLG3 Char Width 001
Col13=FLG4 Char Width 001
Col14=FLG5 Char Width 001
Col14=FLG6 Char Width 001
この実行にDebug.Printをいれたイミディエイト
ＣＳＶファイルをＳＱＬで検索している。
##郵便番号から住所変換 その３ Web版（MSXML2.XMLHTTP.3.0）
郵便番号で日本郵便サイトを検索し、応答の中から文字列処理をして住所を返す
Set oXMLHTTP = CreateObject("MSXML2.XMLHTTP.3.0")
oXMLHTTP.Open "GET", "https://www.post.japanpost.jp/cgi-zip/zipcode.php?zip=" & postAddress, False
oXMLHTTP.Send
If oXMLHTTP.Status = 200 Then
resData = oXMLHTTP.responseText
’ここで受信情報から住所を探す
End If
End If
End Function
HTMLが返ってくるので、必要な文字を探す
欲しいとこだけピックアップすると
これを探して、住所にする
##テキストボックスにセルデータを転記する
住所、宛名、差出人の配置は、テキストボックスで行う。
綺麗に配置するため、複数のテキストボックスを配置した。
テキストボックスへ転記するデータは、宛先、差出人設定から、配置しやすいように、ここで編集している。
住所縦書き対応のため、算用数字を漢数字に置き換える
###ワークシート関数をマクロで使う
ワークシートでは、これで 1 → 一 変換できる。しかし、式が長くてメンテしにくい
=SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(ASC(P3),1,"一"),2,"二"),3,"三"),4,"四"),5,"五"),6,"六"),7,"七"),8,"八"),9,"九"),0,"〇")
マクロでワークシート関数を使うには、Application.WorksheetFunction
'-------------------------------------
' 住所縦書きのため
' worksheet関数をマクロで使う
' 1234567890 → 一二三四五六七八九〇
'-------------------------------------
Private Function num2kanji(ByVal fromStr As String)
With Application.WorksheetFunction
fromStr = .Asc(fromStr)
fromStr = .Substitute(fromStr, "1", "一")
fromStr = .Substitute(fromStr, "2", "二")
fromStr = .Substitute(fromStr, "3", "三")
fromStr = .Substitute(fromStr, "4", "四")
fromStr = .Substitute(fromStr, "5", "五")
fromStr = .Substitute(fromStr, "6", "六")
fromStr = .Substitute(fromStr, "7", "七")
fromStr = .Substitute(fromStr, "8", "八")
fromStr = .Substitute(fromStr, "9", "九")
num2kanji = .Substitute(fromStr, "0", "〇")
End With
End Function
##印刷イメージ画面
##ボタン
###戻る、進む
見たままの機能。とあるページで、Findより配列処理がかなり高速であると見たので、配列処理で検索してみた。
Dim myRange As Range
Dim myAry As Variant
Dim ix As Long
With ThisWorkbook.Sheets(addrssSheet)
'-----------------------------
'findを使わない(配列処理の方が速いらしい）
'-----------------------------
Set myRange = .Range(.Cells(1, 3), .Cells(Rows.Count, 1).End(xlUp))
myAry = myRange ' Range を Variant に入れると配列操作できる
For ix = LBound(myAry) To UBound(myAry)
If 処理対象行判定 Then
'ここに処理を書く
'現在の行は、どこかのセルに保存しておく
End If
Next
End With
これが都合よく、現在の行がわかるので、行の上下動作でこのボタンのマクロが書けた
'-------------------------------------
'プレビュー 前後
'-------------------------------------
Public Sub preview(Optional previews As Long = 1)
Dim myRange As Range
Dim myAry As Variant
Dim ix As Long
Dim forfrom As Long
Dim forto As Long
Dim forstep As Long
With ThisWorkbook.Sheets(addrssSheet)
'-----------------------------
'前後宛先
'-----------------------------
Set myRange = .Range(.Cells(1, 3), .Cells(Rows.Count, 1).End(xlUp))
myAry = myRange
If previews = 1 Then
forto = UBound(myAry) '順方向
Else
forto = 1 '逆順方向
End If
For ix = 現在の行 + previews To forto Step previews
If 処理対象行判定 Then
'ここに処理を書く
'現在の行は、どこかのセルに保存しておく
End If
Next
End With
End Sub
ボタンに引数付きでマクロを登録する
'マクロ名 引数'の形式でマクロを登録する
###印刷
現在表示内容を印刷する（説明はありません）
黄色のボタン
###全印刷
印刷対象をすべて印刷する（説明はありません）
ピンクのボタン
###ＳＴＯＰ
トグルスイッチ的な表示 灰色 ←→ 赤 の変更をしている。
###画面プレビュー
回転スイッチ的な表示 画面プレビュ → プリンタプレビュ → 印刷 → 画面プレビュ の変更をしている。
画像切り替えではなく、プロパティを操作する
Select Case .Range(modePrint) '0:画面プレビュ → 1:プリンタプレビュ → 2:印刷 → 0:画面プレビュ の ループ
Case 0
.Range(modePrint).Value = 1
.Shapes.Range(Array(buttonName)).TextFrame2.TextRange.Characters.Text = "プリンタ" & vbCrLf & "プレビュー"
.Shapes.Range(Array(buttonName)).Fill.ForeColor.RGB = RGB(0, 176, 240)
.Shapes.Range(Array(buttonName)).Shadow.ForeColor.RGB = RGB(255, 255, 0)
Case 1
.Range(modePrint).Value = 2
.Shapes.Range(Array(buttonName)).TextFrame2.TextRange.Characters.Text = "印刷"
.Shapes.Range(Array(buttonName)).Fill.ForeColor.RGB = RGB(148, 87, 164)
.Shapes.Range(Array(buttonName)).Shadow.ForeColor.RGB = RGB(255, 255, 0)
Case 2
.Range(modePrint).Value = 0
.Shapes.Range(Array(buttonName)).TextFrame2.TextRange.Characters.Text = "画面" & vbCrLf & "プレビュー"
.Shapes.Range(Array(buttonName)).Fill.ForeColor.RGB = RGB(0, 176, 80)
.Shapes.Range(Array(buttonName)).Shadow.ForeColor.RGB = RGB(255, 255, 0)
End Select