目次

内容

複数のシートをセルA1の値でファイルに分割

  • 分割元のシートを含むブックが開いていることが条件
    Sub セルの内容でシートを分割()
        ' 作業場所の変更
        Dim outDir As String
        outDir = "C:\outdir"
        ChDir outDir
        ' シート別に作業を開始
        Dim sheetNum As Integer
        For sheetNum = 1 To Worksheets.Count
            Worksheets(sheetNum).Activate
            ' シート中のセルから先生の番号を取得
            Dim idsrt = Range("A1").value
            ' ファイルを新規に作成
            Set filelist = CreateObject("Scripting.Dictionary")
            
            ' workbookがなければ作成
            Dim newFileName As String
            newFileName = idstr & ".xls"
            newFilePath = outDir & "\" & newFileName
            If Dir(newFilePath) = "" Then
                Dim NewBook As Workbook
                Set NewBook = Workbooks.Add
                NewBook.SaveAs filename:=newFileName
            Else
                Workbooks.Open (newFilePath)
            End If
            
            'シートをコピー
            Workbooks("base.xls").Sheets(sheetNum).Copy After:=Workbooks(newFileName).Sheets(3)
            
            ' いったんシートを閉じる
            Workbooks(newFileName).Save
            Workbooks(newFileName).Close
            Workbooks("base.xls").Activate
            
        Next sheetNum
    End Sub

住所の変換

  • 住所を名寄せ用に変換し、となりのセルに都道府県名をセットする
  • 変換する住所が入ったセルを選択して実行(タイトル行は含めない)
    Sub 名寄せ用に住所書式を統一()
        ' 県コード一覧
        Dim ken_list
        Set ken_list = CreateObject("Scripting.Dictionary")
        ken_list.Add "愛知県", "20_愛知県"
        ken_list.Add "愛媛県", "38_愛媛県"
        ken_list.Add "茨城県", "09_茨城県"
        ken_list.Add "岡山県", "34_岡山県"
        ken_list.Add "沖縄県", "47_沖縄県"
        ken_list.Add "岩手県", "04_岩手県"
        ken_list.Add "岐阜県", "21_岐阜県"
        ken_list.Add "宮崎県", "45_宮崎県"
        ken_list.Add "宮城県", "02_宮城県"
        ken_list.Add "京都府", "27_京都府"
        ken_list.Add "熊本県", "43_熊本県"
        ken_list.Add "群馬県", "11_群馬県"
        ken_list.Add "広島県", "31_広島県"
        ken_list.Add "香川県", "36_香川県"
        ken_list.Add "高知県", "39_高知県"
        ken_list.Add "佐賀県", "41_佐賀県"
        ken_list.Add "埼玉県", "14_埼玉県"
        ken_list.Add "三重県", "23_三重県"
        ken_list.Add "山形県", "06_山形県"
        ken_list.Add "山口県", "35_山口県"
        ken_list.Add "山梨県", "15_山梨県"
        ken_list.Add "滋賀県", "26_滋賀県"
        ken_list.Add "鹿児島県", "46_鹿児島県"
        ken_list.Add "秋田県", "05_秋田県"
        ken_list.Add "新潟県", "16_新潟県"
        ken_list.Add "神奈川県", "08_神奈川県"
        ken_list.Add "青森県", "03_青森県"
        ken_list.Add "静岡県", "22_静岡県"
        ken_list.Add "石川県", "19_石川県"
        ken_list.Add "千葉県", "12_千葉県"
        ken_list.Add "大阪府", "25_大阪府"
        ken_list.Add "大分県", "44_大分県"
        ken_list.Add "長崎県", "42_長崎県"
        ken_list.Add "長野県", "17_長野県"
        ken_list.Add "鳥取県", "32_鳥取県"
        ken_list.Add "島根県", "33_島根県"
        ken_list.Add "東京都", "13_東京都"
        ken_list.Add "徳島県", "37_徳島県"
        ken_list.Add "栃木県", "10_栃木県"
        ken_list.Add "奈良県", "29_奈良県"
        ken_list.Add "富山県", "18_富山県"
        ken_list.Add "福井県", "24_福井県"
        ken_list.Add "福岡県", "40_福岡県"
        ken_list.Add "福島県", "07_福島県"
        ken_list.Add "兵庫県", "28_兵庫県"
        ken_list.Add "北海道", "01_北海道"
        ken_list.Add "和歌山県", "30_和歌山県"
        ' 変換候補
        Dim city_list
        Set city_list = CreateObject("Scripting.Dictionary")
        city_list.Add "名古屋市", "愛知県"
        city_list.Add "静岡市", "静岡県"
        city_list.Add "横浜市", "神奈川県"
        city_list.Add "川崎市", "神奈川県"
        city_list.Add "浜松市", "静岡県"
        city_list.Add "千葉市", "千葉県"
        city_list.Add "市川市", "千葉県"
        city_list.Add "北九州市", "福岡県"
        city_list.Add "札幌市", "北海道"
        city_list.Add "京都市", "京都府"
        city_list.Add "福岡市", "福岡県"
        city_list.Add "さいたま市", "埼玉県"
        city_list.Add "広島市", "広島県"
        city_list.Add "神戸市", "兵庫県"
        city_list.Add "大阪市", "大阪府"
        city_list.Add "堺市", "大阪府"
        city_list.Add "新潟市", "新潟県"
        city_list.Add "仙台市", "宮城県"
        city_list.Add "青森市", "青森県"
        city_list.Add "大分市", "大分県"
        
        ' 見出しのセット
        Cells(1, ActiveCell.Column + 1).Value = "都道府県"
        ' 選択範囲の処理開始
        Dim src_cell
        For Each src_cell In Selection
            Dim ken, ken_code, address As String
            address = src_cell.Value
            ken = ""
            ken_code = "不明"
            If (Mid(src_cell.Value, 4, 1) = "県") Then
               ken = Left(src_cell.Value, 4)
            Else
               ken = Left(src_cell.Value, 3)
            End If
            ' 県コードのルックアップ
            If ken_list.Exists(ken) Then
                ken_code = ken_list(ken)
            Else
                ' 市町村リストから検索
                Dim city_name
                For Each city_name In city_list.keys
                    If InStr(address, city_name) = 1 Then
                        ' 県コードの取得
                        ken_code = ken_list(city_list(city_name))
                        ' 住所に県を追加
                        src_cell.Value = city_list(city_name) & src_cell.Value
                        
                        Exit For
                    End If
                Next city_name
            End If
            ' となりのセルに値をセット
            src_cell.Offset(0, 1).Value = ken_code
            ' 英数字のみ半角
            Dim newAddress As String
            newAddress = NarrowChange(src_cell.Value)
            ' 横棒を統一
            newAddress = Replace(newAddress, "-", "-")
            ' 最後が「丁目」で終わってなければ「丁目」を「-」に変換
            If (Right(newAddress, 2) <> "丁目") Then
                newAddress = Replace(newAddress, "丁目", "-")
            End If
            ' 「ケ」を小文字にする
            newAddress = Replace(newAddress, "ケ", "ヶ")
            ' 値をセット
            src_cell.Value = newAddress
        Next src_cell
    End Sub
    
    Function NarrowChange(ByVal strString As String) As String
        Dim intLength As Integer
        Dim strCut As String
        intLength = Len(strString)
        Do While strString <> ""
            strCut = Left(strString, 1)
            If (strCut >= "0" And strCut <= "9") _
            Or (strCut >= "A" And strCut <= "Z") _
            Or (strCut >= "a" And strCut <= "z") Then
                NarrowChange = NarrowChange & StrConv(strCut, vbNarrow)
            Else
                NarrowChange = NarrowChange & strCut
            End If
            strString = Mid(strString, 2)
        Loop
    End Function

印刷範囲でシートを分割

  • Excel太閤の出力結果を加工するときに便利
    Sub 印刷範囲でシート分割()
        ' 画面更新を無効化
        Application.ScreenUpdating = False
        Dim baseWs As Worksheet
        Set baseWs = ActiveSheet
        'baseWs.Activate
        '印刷範囲
        
        ' 上の表を削除
    
        Dim sheetCount As Integer
        Dim PB
        Dim LineNum As Integer
        sheetCount = 0
        
        For Each PB In baseWs.HPageBreaks
            sheetCount = sheetCount + 1
            baseWs.Copy After:=Sheets(Sheets.count)
            ActiveSheet.Name = sheetCount
            ' 印刷範囲
            LineNum = ActiveSheet.HPageBreaks(sheetCount).Location.Row
            ' 下を削除
            ActiveSheet.Rows(LineNum & ":65536").Delete
            ' 上を削除
            If (sheetCount <> 1) Then
                Dim topNum As Integer
                topNum = ActiveSheet.HPageBreaks(sheetCount - 1).Location.Row
                ActiveSheet.Rows("2:" & topNum - 1).Delete
                ' 不要な印刷範囲をクリア
                ActiveSheet.HPageBreaks(1).Delete
            End If
        Next PB
        ' 最後の表
        baseWs.Copy After:=Sheets(Sheets.count)
        ActiveSheet.Name = sheetCount + 1
        LineNum = ActiveSheet.HPageBreaks(sheetCount).Location.Row
        ActiveSheet.Rows("2:" & LineNum - 1).Delete
        ' 不要な印刷範囲をクリア
        ActiveSheet.HPageBreaks(1).Delete
        ' 画面更新を有効
        Application.ScreenUpdating = True
    End Sub

トップ   編集 凍結 差分 バックアップ 添付 複製 名前変更 リロード   新規 一覧 単語検索 最終更新   ヘルプ   最終更新のRSS
Last-modified: 2016-09-25 (日) 19:27:03 (446d)