Sample Macro  その他・サンプルマクロ Previous Next

1) 受信データ自動編集 このページのトップへ もくじへ 使用可能なExcelのバージョン
'=================================================================================

 すぐに役立つエクセルVBAマクロ集  受信データ自動編集  ★Copyright(c)1998 Yoshioh Nagai★

'=================================================================================
Option Explicit
Dim ドライブ As String                          '受信ファイルが存在するドライブ
Dim フォルダー As String                        'フォルダー名
Dim 拡張子 As String                            'ファイルタイプ(拡張子)
Dim 記入シート As String                        'ファイル名が記入用されているシート名
Dim 読込シート As String                        '読んだ値を貼り付けるシート名
Dim パス As String                              'フォルダー名を含むパス
Dim ファイル名 As String                        'パスを含んだファイル名
Dim 一覧より As String                          'ファイル一覧からのファイル名
Dim 結果シート As String                        '最終結果のシート名
Dim 作業シート As String                        '一時的な作業シート名
Dim 整理シート As String                        '一時的な整理シート名
Dim 貼付行 As Integer                           '貼付行ポインタ
Dim バフ(3) As String                           'テキストファイルの読み込み用のバッファー
Dim 取出順 As Integer                           '取出順ポインタ
Dim 下端 As Integer                             'シートの下端セルの行番号
Dim 右端 As Integer                             'シートの右端セルの列番号
Dim 列 As String                                '列番号から変換した英字
Dim 式2 As String                               '作業シート用の式
Dim 式3 As String                               '作業シート用の式
Dim 枚数 As Integer                            '印刷枚数
'---------------------------------------------------------------------------------
Sub 受信データ自動編集()                        'カンマ区切りのテキストファイルの場合
    ドライブ = "D"                              '受信ファイルが存在するドライブを指定する
    フォルダー = "受信"                         'フォルダー名を指定する
    拡張子 = "*." & "txt"                       '拡張子を指定する(この例はtxtまたはTXT)
    記入シート = "ファイル一覧"                 'ファイル名が記入用されているシート名を指定
    読込シート = "読込"                         '読んだ値を貼り付けるシート名を指定する
    結果シート = "結果"                         '最終結果のシート名を指定する
    作業シート = "作業"                         '一時的な作業シート名を指定する
    整理シート = "整理"                         '一時的な整理シート名を指定

    Sheets(結果シート).Activate                 '初期画面
    Application.ScreenUpdating = False          '画面を更新しない
    指定フォルダー中の指定拡張子のファイル名をシートに書く
    テキストファイルを順に読み込みシートに貼る
    If 貼付行 = 1 Then
        MsgBox "処理を中止します", vbCritical, "受信データが1件もありません"
        Exit Sub
    End If
    読込シートの範囲を調べて作業シート用の式を作りソートする
    読込シートの値を作業シートの対応する店舗コードのセルに入れる
    作業シートからエラー値をヌルに置換しながら整理シートへ写す
    整理シートの店舗コード以外の値を結果シートに写す
    枚数 = 貼付行
    ActiveSheet.PrintOut Copies:=枚数           '指定枚数を印刷する
End Sub
'---------------------------------------------------------------------------------
Private Sub 指定フォルダー中の指定拡張子のファイル名をシートに書く()
    Sheets(記入シート).Activate                 'ファイル名を記入用シートをアクティブに
        Cells.Clear                             'すべてクリア
        Range("A1").Select
    パス = ドライブ & ":\" & フォルダー & "\"   'パスを組む
    ファイル名 = Dir(パス & 拡張子)            '指定された拡張子のファイル名を取り出す
    貼付行 = 0                                  '貼付行ポインタを初期化する

    Do While ファイル名 <> ""                   '取り出したファイル名がヌルでなければ
        貼付行 = 貼付行 + 1                     '貼付行ポインタを上げる
        Cells(貼付行, 1).Value = ファイル名     'セルにファイル名を記入する
        ファイル名 = Dir()                      '次のファイル名を取り出す
    Loop                                        '繰り返し処理
End Sub
'---------------------------------------------------------------------------------
Private Sub テキストファイルを順に読み込みシートに貼る() 'カンマ区切りのテキストファイル
    Sheets(読込シート).Activate                 '読んだ値を貼り付けるシートをアクティブに
        Cells.Clear                             'すべてクリア
        Range("A1").Select
    取出順 = 0                                  '取出順ポインタを0にする
    貼付行 = 1                                  '貼付行ポインタを1にする

受信ファイル名を取り出す:
    取出順 = 取出順 + 1
    一覧より = Sheets(記入シート).Cells(取出順, 1)
    If 一覧より <> "" Then                      'ファイル一覧からの値がヌルでなければ
        If Right(一覧より, 4) <> ".txt" And Right(一覧より, 4) <> ".TXT" Then '.txt以外
            GoTo 受信ファイル名を取り出す
        End If
        ファイル名 = パス & 一覧より            'パスとファイル一覧からのファイル名
        Open ファイル名 For Input As #1         'テキストファイルを開く
        Do Until EOF(1)                         'フアイルが終りでなければループする
            バフ(1) = "": バフ(2) = "": バフ(3) = ""
            On Error GoTo 不正データ
            Input #1, バフ(1), バフ(2), バフ(3) 'テキストファイルを読み込む
            On Error GoTo 0
            If バフ(1) <> "" Then               '店舗コードは絶対必要
                Cells(貼付行, 1) = バフ(1)      '読み込んだ値をセルに写す
                Cells(貼付行, 2) = バフ(2)
                Cells(貼付行, 3) = バフ(3)
                貼付行 = 貼付行 + 1             '貼付行ポインタを上げる
            End If
        Loop                                    '次のデータへ
        Close #1                                'テキストファイルを閉じる
        GoTo 受信ファイル名を取り出す           '次のファイルへ
    End If
    貼付行 = 貼付行 - 1                         '貼付した行数に補正する
    Exit Sub

不正データ:
    MsgBox "このまま処理を続けます", vbCritical, _
    "フォーマット不正のデータがみつかりました ・・ " & ファイル名
    Resume Next
End Sub
'---------------------------------------------------------------------------------
Private Sub 読込シートの範囲を調べて作業シート用の式を作りソートする()
    Sheets(読込シート).Select
        Range("A1").Select
        下端 = Range("A1").End(xlDown).Row       '下端検出
        右端 = Range("A1").End(xlToRight).Column '右端検出
        列 = 列番号変換(右端)
        式2 = "=VLOOKUP(A2," & 読込シート & "!$A$1:$" & 列 & "$" & 下端 & ",2,FALSE)"
        式3 = "=VLOOKUP(A2," & 読込シート & "!$A$1:$" & 列 & "$" & 下端 & ",3,FALSE)"
        Selection.SortSpecial SortMethod:=xlSyllabary, Key1:=Range("A1"), _
            Order1:=xlAscending, Header:=xlNo, OrderCustom:=1, MatchCase _
            :=False, Orientation:=xlTopToBottom 'ソートする
End Sub
'---------------------------------------------------------------------------------
Function 列番号変換(列 As Integer) As String    '列番号をA1形式に変換する
    Dim 列番号 As String
    Dim 上位 As Integer
    Dim 余り As Integer
    If 列 <= 26 Then
        列番号 = Chr(列 + 64)
    Else
        上位 = Int(列 / 26)
        余り = 列 Mod 26
        If 余り = 0 Then
            列番号 = Chr(上位 + 63) & "Z"
        Else
            列番号 = Chr(上位 + 64) & Chr(余り + 64)
        End If
    End If
    列番号変換 = 列番号
End Function
'---------------------------------------------------------------------------------
Private Sub 読込シートの値を作業シートの対応する店舗コードのセルに入れる()
    Sheets(作業シート).Select
        Cells.Clear                             'すべてクリア
    Sheets(整理シート).Select
        Cells.Clear

    Sheets(結果シート).Select
        Range("A1").CurrentRegion.Copy          'アクティブセル領域をコピー
    Sheets(整理シート).Select
        Range("A1").PasteSpecial Paste:=xlValues '値を貼り付け
    Sheets(作業シート).Select
        Range("A1").PasteSpecial Paste:=xlValues '値を貼り付け
        下端 = Range("A1").End(xlDown).Row       '下端検出
        右端 = Range("A1").End(xlToRight).Column '右端検出
        Range(Cells(2, 2), Cells(下端, 右端)).Clear 'データのセルをすべてクリア
        Range("B2") = 式2
        Range("C2") = 式3
        Range("B2:C2").Select
            Selection.Copy
        Range("B3:C11").Select
            Selection.PasteSpecial Paste:=xlFormulas  '数式を貼り付け
End Sub
'---------------------------------------------------------------------------------
Private Sub 作業シートからエラー値をヌルに置換しながら整理シートへ写す()
    Sheets(整理シート).Select
        式2 = "=IF(ISERROR(" & 作業シート & "!B2)," & Chr(34) _
            & Chr(34) & "," & 作業シート & "!B2)"
        Range("B2") = 式2
        Range("B2").Copy                         'コピー
        Range("C2").PasteSpecial Paste:=xlAll   'すべて貼り付け
        Range("B2:C2").Copy
        Range("B3:C11").Select
            Selection.PasteSpecial Paste:=xlAll
End Sub
'---------------------------------------------------------------------------------
Private Sub 整理シートの店舗コード以外の値を結果シートに写す()
    Sheets(整理シート).Select
        Range(Cells(2, 2), Cells(下端, 右端)).Copy
    Sheets(結果シート).Select
        Range("B2").Select
             Selection.PasteSpecial Paste:=xlValues
        Range("B2").Select
End Sub
'=================================================================================
          ★ 受信データ自動編集 ★         V1.0                      (C)1998.9.12
'=================================================================================
<コメント>
ダウンロード すれば実際に動かして試せます。
この場合のテストデータの準備方法などは、ダウンロードしたReadme.txtを読んでください。

Excel VBA Macro