Sub MyZipJigyosyo()
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  Rem 事業所の個別郵便番号簿 作成処理
  Rem 作譜：Hitrock Camellia Shinopy
  Rem 言語：Excel VBA
  Rem 機能...
  Rem   都道府県別に事業所の個別郵便番号データをブックに取り込みする。
  Rem 注記...
  Rem   1. 実行前に日本郵政公社のサイトから、
  Rem      [事業所の個別郵便番号最新全データ]をダウンロードしておくこと。
  Rem      （ http://www.post.japanpost.jp/zipcode/dl/jigyosyo/index.html ）
  Rem   2. MyZipJigyosyoReportFootプロシージャ（[プロパティ]の設定）を
  Rem      必要に応じて確認／更新すること。
  Rem   3. 実行前に「myFile」に事業所の個別郵便番号データファイルの保存先を指定すること。
  Rem   4. MyZipJigyosyoを起動して実行。
  Rem 履歴...
  Rem   第01版：2007/08/07：作成。
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  Dim myFile As String
  Dim myBuffer As String
  Dim tmp As Variant
  Dim myPrefPrev As String
  Dim r As Long
  Dim i As Long
  Dim myMax As Long
  Dim myStatusBar As String
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
  myFile = "C:\Documents and Settings\User\My Documents\Download\郵便番号\JIGYOSYO.CSV"
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
  Application.CommandBars("Task Pane").Visible = False
  On Error Resume Next
  Open myFile For Input As #1
  Line Input #1, myBuffer
  '
  If Err.Number <> 0 Then
    myStatusBar = Err.Description
    Application.Speech.Speak myStatusBar, True
    myStatusBar = "MyZipJigyosyo" & ": " & myStatusBar
    Application.StatusBar = myStatusBar
    Close #1
    Exit Sub
  End If
  On Error GoTo 0
  If EOF(1) Then Exit Sub
  '
  Application.ScreenUpdating = False
  '
  myBuffer = Replace(myBuffer, Chr(34), "")
  tmp = Split(myBuffer, ",")
  '
  myPrefPrev = tmp(3)
  Call MyZipJigyosyoPageHead
  ActiveSheet.Name = myPrefPrev
  Close #1
  '
  Rem  なぜか、データ件数が1つ多い数字を取得するため、1を減算。
  Rem  （郵便番号データファイルの[全国一括]データ 平成19年6月29日更新版での現象）
  With CreateObject("Scripting.FileSystemObject").OpenTextFile(myFile, 8)
    myMax = .Line - 1
    .Close
  End With
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
  r = 0
  i = 0
  Open myFile For Input As #1
  '
  Do Until EOF(1)
    r = r + 1
    i = i + 1
    Line Input #1, myBuffer
    '
    myBuffer = Replace(myBuffer, Chr(34), "")
    tmp = Split(myBuffer, ",")
    '
    If tmp(3) <> myPrefPrev Then
      On Error Resume Next
      ActiveSheet.Next.Select
      If Err.Number <> 0 Then
        Worksheets.Add After:=ActiveSheet
      End If
      On Error GoTo 0
      '
      myPrefPrev = tmp(3)
      Call MyZipJigyosyoPageHead
      ActiveSheet.Name = myPrefPrev
      r = 1
    End If
    Cells(r, 1).Resize(1, 13) = tmp
    '
    If Cells(r, 1).Errors(xlNumberAsText).Value = True Then
      Cells(r, 1).Errors(xlNumberAsText).Ignore = True
    End If
    If Cells(r, 7).Errors(xlNumberAsText).Value = True Then
      Cells(r, 7).Errors(xlNumberAsText).Ignore = True
    End If
    If Cells(r, 8).Errors(xlNumberAsText).Value = True Then
      Cells(r, 8).Errors(xlNumberAsText).Ignore = True
    End If
    If Cells(r, 9).Errors(xlNumberAsText).Value = True Then
      Cells(r, 9).Errors(xlNumberAsText).Ignore = True
    End If
    If Cells(r, 11).Errors(xlNumberAsText).Value = True Then
      Cells(r, 11).Errors(xlNumberAsText).Ignore = True
    End If
    If Cells(r, 12).Errors(xlNumberAsText).Value = True Then
      Cells(r, 12).Errors(xlNumberAsText).Ignore = True
    End If
    If Cells(r, 13).Errors(xlNumberAsText).Value = True Then
      Cells(r, 13).Errors(xlNumberAsText).Ignore = True
    End If
    '
    myStatusBar = i * 100 \ myMax & "%  " & i & "/" & myMax & "件　"
    myStatusBar = "[" & ActiveSheet.Name & "]：" & myStatusBar
    Application.StatusBar = "MyZipJigyosyo" & "：" & myStatusBar
    '
    DoEvents
  Loop
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
  Application.ScreenUpdating = True
  Close #1
  '
  Call MyZipJigyosyoReportFoot
  myStatusBar = "処理が終了しました。"
  Application.Speech.Speak myStatusBar, True
  myStatusBar = "MyZipJigyosyo" & ": " & myStatusBar & Now() & " "
  Application.StatusBar = myStatusBar & i & "件"
End Sub ' MyZipJigyosyo *----*----*    *----*----*    *----*----*    *----*----*

Sub MyZipJigyosyoPageHead(Optional myDummy As Boolean)
  Columns("A:M").Select
  Selection.NumberFormatLocal = "@"
  '
  Columns("A:A").Select
  Selection.ColumnWidth = 7
  '
  Columns("C:C").Select
  Selection.ColumnWidth = 75
  '
  Columns("H:H").Select
  Selection.ColumnWidth = 9
  '
  Columns("K:M").Select
  Selection.ColumnWidth = 3
  '
  Range("A1").Select
End Sub ' MyZipJigyosyoPageHead *----*----*    *----*----*    *----*----*    *----*----*

Sub MyZipJigyosyoReportFoot(Optional myDummy As Boolean)
  Rem [プロパティ]の設定
  Rem タイトル・サブタイトル・ハイパーリンクの基点
  ActiveWorkbook.BuiltinDocumentProperties("Title") = "事業所の個別郵便番号"
  ActiveWorkbook.BuiltinDocumentProperties("Subject") = "平成19年 7月 31日更新版"
  ActiveWorkbook.BuiltinDocumentProperties("Hyperlink base") = "http://www.post.japanpost.jp/zipcode/dl/jigyosyo/index.html"
End Sub ' MyZipJigyosyoReportFoot *----*----*    *----*----*    *----*----*    *----*----*