[[20200830201001]]　『CSVファイルを読み込み、バッチ番号ごとにCSV出力』（おかもと）　ページの最後に飛ぶ

『CSVファイルを読み込み、バッチ番号ごとにCSV出力したい』（おかもと）

倉庫管理システムでバッチ番号を含めた出荷指示CSVデータがあります。
AF列には、バッチ番号が付与されたコードが出力されます。
そのコードの先頭に付与されるバッチ番号ごとに新しいシートにデータをコピーし、そのシートをCSV出力するマクロを組みたいです。

・バッチ番号
例：176-3/17-3/52-M-S　の　176の部分
1桁～3桁の数字であり、桁数は可変。

・読み込むCSVファイル
名前例：送り状_B2クラウドネコポス_yyyymmdd_hhnnss.csv
"yyyymmdd_hhnnss"の部分は、CSVをシステムから出力したときの日時であり、固定。

・CSV出力
新規シートを作成し、バッチ番号ごとにデータをコピー。
シート名にバッチ番号（176）
出力先は、新規フォルダをシート名（176）にして作成し、ファイル名は"送り状_B2クラウドネコポス_yyyymmdd_hhnnss.csv"で保存。

【全体の流れ】
1.CSVファイルの読み込み
2.バッチ番号の確認
3.バッチ番号ごとにシートを作成（シート名：バッチ番号）し、データをコピー
4.CSV出力（フォルダ名＝シート名、CSVファイル名は読み込んだCSVファイルを同じ名前）

似た内容は下記URLのような動作かと思います。
https://oshiete.goo.ne.jp/qa/8440980.html?from=recommend

2.のバッチ番号の識別で躓き、2週間ほど経過しています。
FIND関数やLEFT関数を組み合わせて検索出力すると、
「1」と「11」が区別できないためすべて同じシートに出力されてしまいます。
知識も経験もないため、検索キーワードさえ間違っているかもしれません。
どうぞよろしくお願いいたします。

＜使用 Excel：Excel2016、使用 OS：Windows10 ＞

＞「1」と「11」が区別できないためすべて同じシートに出力されてしまいます

どのようにしたのか、とちあえず現状のコードを提示していただけますか

（マナ） 2020/08/30(日) 20:42

ありがとうございます。
まったくの初心者でしたので、以下のサイトからサンプルデータを拝借しました。
http://vba-belle-equipe.hatenablog.com/entry/2019/08/18/112049

こちらのシートのD15に以下のような関数を入れたところです。

"=LEFT(ADDRESS(1,C14,1,1),3)&":"&LEFT(ADDRESS(1,C14,1,1),3)"

理想といたしましては、手動で入力することなく、
ファイルを読み込み～CSV出力まで完了させたいと思います。

（おかもと） 2020/08/30(日) 20:48

間違えました。
どこまでマクロができているか提示お願いします。
エラーがでる中途半端なもので結構です。

（マナ） 2020/08/30(日) 21:02

下記URLを参照しながら試行錯誤したもの
https://oshiete.goo.ne.jp/qa/8440980.html?from=recommend

Sub macro1()

  Dim myPath As String
  Dim myFile As String
  Dim h As Range
  Dim s As String
  Dim w As Worksheet

  myPath = ThisWorkbook.Path & "\"
  On Error Resume Next
  Kill myPath & "*.csv"
  Application.DisplayAlerts = False
  For Each w In Worksheets
    If w.Name <> ActiveSheet.Name Then w.Delete
  Next
  Application.DisplayAlerts = True
  On Error GoTo errhandle

  For Each h In Range("AF" & Range("A65536").End(xlUp).Row)
  If IsNumeric(h.Value) Then
    s = Left(h.Valuer, 3)

  'ＣＳＶに書き出し
    Open myPath & "uriage" & s & ".csv" For Append As #1
    Print #1, h.Value & "," & h.Offset(0, 1).Value
    Close #1

  'シートに書き出し
    h.EntireRow.Copy Worksheets(s).Range("A65536").End(xlUp).Offset(1)

  End If
  Next

  For Each w In Worksheets
    w.Columns("A:B").AutoFit
  Next
  Exit Sub

errhandle:

  Worksheets.Add after:=Worksheets(Worksheets.Count)
  ActiveSheet.Name = s
  Range("A1:CQ") = Array("date", "value")
  Resume
End Sub

（おかもと） 2020/08/30(日) 21:33

下記URLを見ながら試行錯誤したもの。
http://vba-belle-equipe.hatenablog.com/entry/2019/08/18/112049

Option Explicit

Public Const ファイルアドレス As String = "C3"
Public Const 検索列アドレス As String = "D7"
Public Const 検索語アドレス As String = "D8"
Public Const csv行数アドレス As String = "D9"
Public Const 該当件数アドレス As String = "D10"
Public Const 対象列アドレス As String = "D14"

Sub シート作成()

    Dim sheetName As String
    Dim ws As Worksheet
    Dim csvWS As Worksheet
    Dim newWS As Worksheet

    Set ws = ThisWorkbook.Sheets("操作")
    Set csvWS = ThisWorkbook.Sheets("csv")
    sheetName = ws.Range(検索語アドレス)
    If sheetName = "" Then
        Call 異常終了("検索語を入力してください")
    End If

    Dim cnt As Variant
    cnt = ws.Range(該当件数アドレス)
    If IsError(cnt) Then
        Call 異常終了("ファイルが読み込まれてません")
    End If
    If cnt = 0 Then
        Call 異常終了("該当するデータがありません")
    End If

    Application.ScreenUpdating = False

    Call 不要シート削除
    Set newWS = Worksheets.Add(After:=Sheets(2))
    newWS.Name = sheetName

    Dim i As Long, j As Long
    Dim maxRow As Long
    Dim crRow As Long
    Dim buf As String
    Dim targetCol As Long
    targetCol = ws.Range(対象列アドレス)

    With csvWS
        .Rows(1).Copy newWS.Rows(1)
        maxRow = .Cells(Rows.Count, 1).End(xlUp).Row
        crRow = 1
        For i = 2 To maxRow
            '検索語と比較する文字列の作成
            buf = .Cells(i, targetCol)

            If InStr(buf, sheetName) > 0 Then
                crRow = crRow + 1
                .Rows(i).Copy newWS.Rows(crRow)
            End If
        Next
    End With
    newWS.Cells(1, 1).Select

    Application.ScreenUpdating = True
End Sub

Sub ファイル読込()

    Dim filePath As String
    Dim ws As Worksheet

    filePath = ThisWorkbook.Sheets("操作").Range(ファイルアドレス)
    If filePath = "" Then
        Call 異常終了("ファイルを選択してください")
    End If
    Set ws = ThisWorkbook.Sheets("csv")
    Call CSV読込(filePath, ws)
    Call 検索列入力リスト設定

    MsgBox "読み込みました"
    ws.Activate

     With ActiveSheet.QueryTables.Add(Connection:="TEXT;" & filePath, _
        Destination:=Range("A1"))
        .TextFilePlatform = 932
        .TextFileStartRow = 1
        .TextFileParseType = xlDelimited
        .TextFileTextQualifier = xlTextQualifierDoubleQuote
        .TextFileConsecutiveDelimiter = False
        .TextFileTabDelimiter = True
        .TextFileSemicolonDelimiter = False
        .TextFileCommaDelimiter = True
        .TextFileSpaceDelimiter = False
        .TextFileColumnDataTypes = Array(2, 1, 1, 1, 5, 1, 1, 1, 2, 1, 2, 1, 1, 1, 1, 1, 1, 1, 1, 2, 1, _
        2, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 2, 2, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1 _
        , 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1)
        .TextFileTrailingMinusNumbers = True
        .Refresh BackgroundQuery:=False
    End With
End Sub

Sub シートクリア()

    ThisWorkbook.Sheets("csv").Cells.Clear
    With ThisWorkbook.Sheets("操作").Range(検索列アドレス)
        .Validation.Delete
        .Value = ""
    End With
    Call 不要シート削除
End Sub

Sub ファイル選択()

    Dim str
    Dim filePath As String
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Sheets("操作")

    With Application.FileDialog(msoFileDialogOpen)
        .AllowMultiSelect = False
        .InitialFileName = ActiveWorkbook.Path
        If .Show = True Then
            filePath = .SelectedItems(1)
        Else
            Exit Sub
        End If
    End With

    str = Application.Caller
    Select Case str
        Case "ファイル選択１"
            ws.Range(ファイルアドレス) = filePath
        Case Else

    End Select

End Sub

（おかもと） 2020/08/30(日) 21:35

Option Explicit

Function ブックを開く(filePath As String) As Workbook

    Dim buf As String
    Dim wb As Workbook
    Dim targetWB As Workbook
    Dim flg As Boolean

    If filePath = "" Then
        Call 異常終了("ファイルを指定してください")
    End If

    ''ファイルの存在チェック
    buf = Dir(filePath)
    If buf = "" Then
        Call 異常終了(filePath & vbCrLf & "は存在しません")
    End If
    ''同名ブックのチェック
    For Each wb In Workbooks
        If wb.Name = buf Then
            Set targetWB = wb
            flg = True
            Exit For
        End If
    Next wb

    If flg = False Then
        Set targetWB = Workbooks.Open(filePath)
    End If

    Set ブックを開く = targetWB
End Function

Sub 異常終了(msg As String)

    Application.ScreenUpdating = True
    MsgBox (msg)
    End
End Sub

Sub CSV読込(targetFilePath As String, targetCSV As Worksheet)

    Dim thisWS As Worksheet
    Set thisWS = ThisWorkbook.Sheets("操作")

    targetCSV.AutoFilterMode = False
    targetCSV.Cells.Clear
    Application.ScreenUpdating = False

    '対象csvを読み込んで一時シートに貼り付けて閉じる
    Workbooks.Open fileName:=targetFilePath
    ActiveSheet.Cells.Copy targetCSV.Cells
    ActiveWorkbook.Close SaveChanges:=False

End Sub

Sub CSV出力()

    Dim fileName As String
    Dim filePath As String
    Dim ws As Worksheet
    Dim cnt As Long
    cnt = ThisWorkbook.Worksheets.Count
    If cnt < 3 Then
        MsgBox "シートが作成されていません"
        End
    End If
    Set ws = ThisWorkbook.Sheets(3)
    fileName = ws.Name & ".csv"
    filePath = ActiveWorkbook.Path & fileName
    Call writeCSV(ws, filePath)
    MsgBox filePath & " に CSVファイルを出力しました"
End Sub

Sub xlsx出力()

    Dim fileName As String
    Dim filePath As String
    Dim ws As Worksheet
    Dim cnt As Long
    cnt = ThisWorkbook.Worksheets.Count
    If cnt < 3 Then
        Call 異常終了("シートが作成されていません")
    End If
    Set ws = ThisWorkbook.Sheets(3)
    fileName = ws.Name & ".xlsx"
    filePath = ActiveWorkbook.Path & fileName
    ws.Copy
    ActiveWorkbook.SaveAs filePath
    ActiveWorkbook.Close
    MsgBox filePath & " に xlsxファイルを出力しました"
End Sub

Sub writeCSV(ws As Worksheet, filePath As String)

    Dim i As Long, j As Long
    Dim buf As String
    Dim maxRow As Long
    Dim maxCol As Long

    With ws
        maxRow = .Cells(Rows.Count, 1).End(xlUp).Row
        maxCol = .Cells(1, Columns.Count).End(xlToLeft).Column
    End With

    Open filePath For Output As #1

    For i = 1 To maxRow
        For j = 1 To maxCol
            buf = 空欄スペース埋め(ws.Cells(i, j).Value)
            Print #1, buf & ",";
        Next
        buf = 空欄スペース埋め(ws.Cells(i, j).Value)
        Print #1, buf & vbCr;
    Next
    Close #1

End Sub

Function 空欄スペース埋め(str As String) As String

    str = Trim(str)
    Debug.Print Len(str) & "_" & str
    If str = "" Then
        str = "　"
    End If
    空欄スペース埋め = str
End Function

Sub 不要シート削除()

    Dim v As Variant
    Dim i As Long
    Dim cnt As Long
    Dim ws As Worksheet
    Dim flg As Boolean

    Application.DisplayAlerts = False
    v = Array("操作", "csv")
    cnt = UBound(v)
    For Each ws In ThisWorkbook.Sheets
        flg = False
        For i = 0 To cnt
            If ws.Name = v(i) Then
                flg = True
                Exit For
            End If
        Next
        If flg = False Then
            ws.Delete
        End If
    Next
    Application.DisplayAlerts = True
End Sub

Sub 検索列入力リスト設定()

    Dim maxCol As Long
    Dim rng As Range
    With ThisWorkbook.Sheets("csv")
        maxCol = .Cells(1, Columns.Count).End(xlToLeft).Column
        If maxCol < 1 Then
            Exit Sub
        Else
            Set rng = .Range(.Cells(1, 1), .Cells(1, maxCol))
        End If
    End With

    With ThisWorkbook.Sheets("操作").Range(検索列アドレス).Validation
        .Delete
        .Add Type:=xlValidateList, _
             Operator:=xlEqual, _
             Formula1:="=csv!" & rng.Address
    End With
End Sub

（おかもと） 2020/08/30(日) 21:36

下のコードでは、「18」で検索すると以下全てが含まれてしまいます。
「177-1/12-18/52-M-S」
「180-…」
「181-…」

（おかもと） 2020/08/30(日) 21:40

CSVの読み込みところでは、ファイル名が
「"送り状_B2クラウト゛ネコホ゜ス_" & yyyymmdd_hhnnss .csv"」では開けないので、
日付時刻の形式について検索しましたが、（Format, yyyy...）や（Now , ...）等が出てくるのですが
現在の日時ではなくてただの文字列で表す方法が分からなくなっています。

Dim connection As String
Dim qt As QueryTable
connection = "TEXT;" & ThisWorkbook.Path & "\Book1.csv"
Set qt = ActiveSheet.QueryTables.Add( _

    Connection:=connection, Destination:=Range("B2") _
)

With qt

        .TextFilePromptOnRefresh = False
        .TextFilePlatform = 932
        .TextFileStartRow = 1
        .TextFileParseType = xlDelimited
        .TextFileTextQualifier = xlTextQualifierDoubleQuote
        .TextFileConsecutiveDelimiter = False
        .TextFileTabDelimiter = True
        .TextFileSemicolonDelimiter = False
        .TextFileCommaDelimiter = True
        .TextFileSpaceDelimiter = False
        .TextFileColumnDataTypes = Array(2, 1, 1, 1, 5, 1, 1, 1, 2, 1, 2, 1, 1, 1, 1, 1, 1, 1, 1, 2, 1, _
        2, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 2, 2, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1 _
        , 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1)
        .TextFileTrailingMinusNumbers = True
        .Refresh BackgroundQuery:=False
    End With
End sub
（おかもと） 2020/08/30(日) 21:48

読み込むCSVファイルの最終列はCQです。
電話番号や郵便番号欄等の文字は、文字列を選択しています。
システムから出力されるファイルはutf-8です。
１行目のヘッダもコピーに含めます。
（おかもと） 2020/08/30(日) 21:51

こんな感じでもよいですか

 【全体の流れ】
 1.CSVファイルをマクロブックに読み込み
 2.CR列でバッチ番号を算出
 3.CZ列にバッチ番の重複なしのリスト作成（フィルタオプション）
 4.CZ列のバッチ番号を抽出条件に、作業用シートに転記（フィルタオプション）
 5.作業用シートを新規ブックにコピー
 6.バッチ番号名のフォルダ作成
 7.5のブックを名前を付けて保存し、閉じる
 8.すべてのバッチ番号で、4～7を繰り返し+
（マナ） 2020/08/30(日) 22:19

ありがとうございます。
7.　の貼り付けた後にCR列とCZ列の削除も可能でしょうか？
（おかもと） 2020/08/31(月) 05:26

 横から失礼します。

 最近似たような処理を依頼されることが多いのですが（というか EC 関連で CSV 処理したいって需要多いですね＾＾）、
 UTF-8、CSV を処理する場合はいろいろと気を付けたほうが良い点がありそうです。
　・UTF-8 はBOM 無しだと文字化けすることがある。
　・文字列として読込まないと、０付きの数字が０無しの数値になる
　・文字列として読込まないと、3-4 のようなデータが日付になる
　・元データが "" で囲まれたデータであっても、EXCEL から CSV 保存すると"" 無しになる
　・""無しで、データ内に改行（実際はLFだったり垂直タブだったり）があると、読込み先で正常に読めないこともある

 ですので、私だったらですが、行データをいじらないようにして、
 （１）ADODB.Stream で開いて一括読み込みし、改行コード（" があれば """" & vbCRLF など）でSplit
 （２）処理行のバッチ番号を取得（"があれば """,""" でSplit して指定列で）
 （３）バッチ番号のフォルダがなかったら.\[バッチ番号]\ファイル名フォルダを作成
       ※タイトル行があれば最初に出力
 （４）.\[バッチ番号]\ファイル名 に追記
 （５）（２）～（４）をすべての行で繰り返す。

 というような処理方法をとっています。
 ※出力が BOM 付きである必要があれば、BOM 追加の処理も。

 このあたりすでに対策をご検討済みだったかもしれませんが、好き勝手なことばかり書いて失礼いたしましたm(__)m
（QS） 2020/08/31(月) 09:23

ありがとうございます。

確かにUTF-8で出力しているはずですが、BOMは無いようですので、
ヘッダの項目名が文字化けしました。
また、0付文字が0落ちしますので、文字列指定をしていました。

この部分

" .TextFileColumnDataTypes = Array(2, 1, 1, 1, 5, 1, 1, 1, 2, 1, 2, 1, 1, 1, 1, 1, 1, 1, 1, 2, 1, _

        2, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 2, 2, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1 _
        , 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1)"

私に知識がないために、QS様のような設計を思いつくことができず、また
そのような設計ができる技量もないため、よろしければ1つのご意見として添えていただければ幸いです。
自分の今後のためにもたくさんのパターンを学んでおきたいと思っております。
（おかもと） 2020/08/31(月) 12:42

どうも難しそうですので、QSさんにおまかせします。
（質問者さんと一緒に勉強させていただきます）

（マナ） 2020/08/31(月) 19:06

回答がないため、自分で挑戦していますが、冒頭でエラーが出てしまいます。

 （１）ADODB.Stream で開いて一括読み込みし、改行コード（" があれば """" & vbCRLF など）でSplit

Sub Sample()

    Dim buf As String, Target As String
    Target = "C:\Users\User\Desktop\ファイル名.csv"
    With CreateObject("ADODB.Stream")
        .Charset = "UTF-8"
        .Open
        .LoadFromFile Target
        buf = .ReadText
        .Close
        MsgBox buf
    End With
End Sub

「実行時エラー3002　ファイルを開けませんでした」

デスクトップの任意の場所に、CSVファイルと実行ファイルが存在しています。
ディレクトリを作成して移動させても同じエラー、Charsetがあってもなくてもエラーになります。

（おかもと） 2020/09/03(木) 05:56

 提示のコードでデスクトップに作成した UTF-8 のファイルは開きましたが、パスの取得だけちょっと変更してみました。

 Sub ReadFile()
    Dim wsh
    Set wsh = CreateObject("WScript.Shell")

    Dim target
    target = wsh.SpecialFolders("desktop") & "\test2.csv"

    Dim buf
    With CreateObject("ADODB.Stream")
        .Charset = "UTF-8"
        .Open
        .LoadFromFile target
        buf = .ReadText
        .Close
        MsgBox buf
    End With
End Sub

（QS） 2020/09/03(木) 06:53

 データ内に改行がなく、データの改行コードが CRLF であるなら

 Dim lines
 lines = Split( buf, vbCRLF )

 Dim line
 For Each line In lines
      一行の処理
 Next

 で一行ずつの処理ができます。
 すべての項目が "xxx","xxx", ...  のようになっているなら、

 Dim fields
 fields = Split( line, """,""" )
 で先頭と最後に " が残りますが、2番目以降、最後の手前までは項目だけとなります。
 EXCEL でいう AF 列は32番目なので配列のインデックスは 31 番目ですから、
 バッチ番号が入った項目は fields(31) となります。

 ここからどうバッチ番号を取り出すからは色々ありますが、最初から見ていって
 - か / までが必ず数字であるなら、
 batNum = CLng( Split( Replace( fields(31), "-", "/" ) & "/", "/")(0) ) 
 のように取れるかと思います。
 他の文字がある場合は正規表現で ^\d+ などで。

 あとはそこからパスを取得し
 Set fso = CreateObject("Scripting.FileSystemObject")
 Set srcFile = fso.GetFile( target )
 dstFolder = Replace( srcFile.Path, srcFile.Name, batNum )

 If fso.FolderExists( dstFoder ) = False Then fso.CreateFolder dstFolder
 dstPath = dstFolder & "\" & srcFile.Name

 でこのファイルへ line のまま　追記すればどうでしょうか。
 追記はこのあたりを参考に。
 https://k-sugi.sakura.ne.jp/it_synthesis/windows/vb/3792/

 直接コード書いたので、おかしなところがあったらすみません。
 基本的な考え方として、参考にしていただければと思います。
（QS） 2020/09/03(木) 07:17

デスクトップにあるファイル名は、
「送り状_B2クラウドネコポス_yyyymmdd_hhnnss.csv」となりますが、
同じエラーで開きません。
試しに「Book1.csv」を作成したところ、開きました。
ファイル名に記号や半角全角が含まれていることが原因でしょうか。

（おかもと） 2020/09/03(木) 20:00

こちらは、「実行時エラー9　インデックスが有効範囲にありません。」と表示されます。
宣言が足りていないでしょうか。
データのAF（配列の31）列にバッチ番号は入っている状態です。
「177-1/12-18/52-M-S」の書式は固定となります。

Sub CreateFile()

 Dim lines
 lines = Split(buf, vbCrLf)

 Dim line
 For Each line In lines

 Next

 Dim fields
 fields = Split(line, """,""")

 batNum = CLng(Split(Replace(fields(31), "-", "/") & "/", "/")(0))

  Set fso = CreateObject("Scripting.FileSystemObject")
  Set srcFile = fso.GetFile(target)
  dstFolder = Replace(srcFile.Path, srcFile.Name, batNum)

  If fso.FolderExists(dstFoder) = False Then fso.CreateFolder dstFolder
  dstPath = dstFolder & "\" & srcFile.Name

End Sub
（おかもと） 2020/09/03(木) 20:58

 まず確認したほうが良いのは、セキュリティ関係でしょうか。
 ネットからダウンロードしたファイルは、開けないケースがあるのでメモ帳などで
 一度開いて保存してみてどうでしょうか。

 インデックスは空白行の場合エラーになると思います。
 Debug.Print などでエラーになる行の状態を確認して、空白だったら処理しないなど
 条件処理は適宜追加が必要と思います。
（QS） 2020/09/03(木) 21:49

メモ帳で開くと文字化けはありませんが、右下のステータスにWindows（CRLF）　ANSIと表示されていました。
そのまま名前を付けて保存＞utf-8＞再度同じコードを実行してみましたが、
「実行時エラー3002　ファイルを開けませんでした」となってしまいますね。。。

 Debug.Print と条件について、調べてみます。
ありがとうございます。
（おかもと） 2020/09/03(木) 22:10

また、CSVファイルのプロパティ＞属性欄は読み取り専用のチェックを外し、
更に詳細のメッセージが表示されていた箇所で「許可する」のチェックを付けた状態です。
（おかもと） 2020/09/03(木) 22:13

 コードもおかしいので後程、サンプルを提示します。
 メモ帳で開いたら保存するときは UTF-8 にしてください。

 でも、そもそも ANSI なら fso の TextStream で　ReadAll() でよいのですけれど・・・。
（QS） 2020/09/03(木) 22:16

 乗り掛かった舟なので、簡単なサンプルです。一応こちらで動作検証済みです。

 Option Explicit
 Public fso
 Public wsh
 Public srcPath
 Public srcFileName

 '//------------------------------------------------------
 Sub main()
 '//------------------------------------------------------
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set wsh = CreateObject("WScript.Shell")

    srcPath = Application.GetOpenFilename("CSV ファイル,*.csv")
    If srcPath = "False" Then Exit Sub

    srcFileName = fso.GetFile(srcPath).Name

    Dim lines
    lines = getLines(srcPath)

    Dim line
    Dim n
    For Each line In lines
        n = n + 1
        appendLine n, line
    Next
 End Sub

 '//------------------------------------------------------
 Function getLines(filePath)
 '//------------------------------------------------------
    With CreateObject("ADODB.Stream")
        .Charset = "UTF-8"
        .Open
        .LoadFromFile filePath
        getLines = Split(.ReadText, vbCrLf)
        .Close
    End With
 End Function

 '//------------------------------------------------------
 Sub appendLine(lineNum, line)
 '//------------------------------------------------------
    If line = "" Then Exit Sub

    Dim fields
    fields = Split(line, """,""")
    If UBound(fields) < 31 Then
        MsgBox "項目数が足りません。" & vbNewLine & lineNum & "行目:" & line
        Exit Sub
    End If

    Dim batNumber
    batNumber = CLng(Split(Replace(fields(31), "-", "/") & "/", "/")(0))

    Dim dstFolder
    dstFolder = Replace(srcPath, srcFileName, batNumber)

    Dim dstPath
    dstPath = dstFolder & "\" & srcFileName

    If fso.FolderExists(dstFolder) = False Then fso.CreateFolder dstFolder
    With CreateObject("ADODB.Stream")
        .Mode = 3 '読み取り/書き込みモード
        .Type = 2 'テキストデータ
        .Charset = "UTF-8"
        .Open
        If fso.FileExists(dstPath) = False Then
            .LoadFromFile dstPath
            .Position = .Size 'ポインタを終端へ
        End If
        .WriteText line, 1
        .SaveToFile dstPath, 2
        .Close
    End With
 End Sub

 UTF-8 ファイル、改行コードは CRLF、データ中に改行無し、全フィールドが""で囲まれている前提です。
（QS） 2020/09/03(木) 22:46

batNumber = CLng(Split(Replace(fields(31), "-", "/") & "/", "/")(0))

こちらで「型が一致しません」というエラが出ており、「batNumber」が空になっているようです。

（おかもと） 2020/09/04(金) 05:58

 この行の前に、下記を追加して結果をお知らせください。

 Debug.Print "[" & fields(31) & "]" _
 & "[" & Split(Replace(fields(31), "-", "/") & "/", "/")(0) & "]" _
 & "[" & IsNumeric(Split(Replace(fields(31), "-", "/") & "/", "/")(0)) & "]"

 おそらく CLng で変換できない（数値と認識できる文字列ではない）のが
 原因のような気がします。

 ステップ実行しながら、変数確認すれば確認も容易になるかと思いますが、
 こういった作業が原因を追究するためのデバッグ作業です。
（QS） 2020/09/04(金) 07:11

朝早くからありがとうございます。
結果は同じでした。
デバッグ＞ステップイン(F8)を押下して順番に追ってみると、
こちらの行でエラーとなります。

「実行時エラー　13　型が一致しません。」

 batNumber = CLng(Split(Replace(fields(31), "-", "/") & "/", "/")(0))

'//------------------------------------------------------

 Sub appendLine(lineNum, line)
 '//------------------------------------------------------
    If line = "" Then Exit Sub
    Dim fields
    fields = Split(line, """,""")
    If UBound(fields) < 31 Then
        MsgBox "項目数が足りません。" & vbNewLine & lineNum & "行目:" & line
        Exit Sub
    End If
    Dim batNumber

     Debug.Print "[" & fields(31) & "]" _
    & "[" & Split(Replace(fields(31), "-", "/") & "/", "/")(0) & "]" _
    & "[" & IsNumeric(Split(Replace(fields(31), "-", "/") & "/", "/")(0)) & "]"

    batNumber = CLng(Split(Replace(fields(31), "-", "/") & "/", "/")(0))

    Dim dstFolder
    dstFolder = Replace(srcPath, srcFileName, batNumber)
    Dim dstPath
    dstPath = dstFolder & "\" & srcFileName
    If fso.FolderExists(dstFolder) = False Then fso.CreateFolder dstFolder
    With CreateObject("ADODB.Stream")
        .Mode = 3 '読み取り/書き込みモード
        .Type = 2 'テキストデータ
（おかもと） 2020/09/04(金) 08:01

"0001","7","","","2020/08/21","",""," ",

ファイルの一部です。
UTF-8 ファイル、改行コードは Windows(CRLF）、改行無し、""で囲まれているものです。
（おかもと） 2020/09/04(金) 08:04

 結果が変わるとは思っていません。
 Debug.Print の表示が VBE の イミディエイトウィンドウ に出ていますので、
 エラーとなったときの表示を教えてください。
 結果は1行も出ないのでしょうか、それとも途中でエラーとなっているのでしょうか。

 イミディエイトウィンドウ が見当たらない場合は、VBE で Ctl+G か 表示から選択で。
（QS） 2020/09/04(金) 08:27

[荷扱い２][荷扱い２][False]

となります。
（おかもと） 2020/09/04(金) 12:35

 ってことは、fields(31) はバッチ番号の列じゃない、あるいはバッチ番号以外のデータがあることもある。
 ってことですよね。

 あっ！！！
 先頭はタイトル行でしょうか？

 であれば、
　　For Each line In lines
 は
    Dim ln
　　For ln = LBound(lines) + 1 To UBound(lines)
        line = lines(ln)

 に書き換えてください。
（QS） 2020/09/04(金) 12:44

先頭はタイトルです！
書き直したところ、取得できたようです！

[荷扱い２][荷扱い２][False]
[38-1/40-1/64-A-S][38][True]

今度は、以下の箇所で「ファイルを開けませんでした」と表示されました。
新しいディレクトリにバッチ番号の頭が付与され、中身が空の状態です。

   With CreateObject("ADODB.Stream")
        .Mode = 3 '読み取り/書き込みモード
        .Type = 2 'テキストデータ
        .Charset = "UTF-8"
        .Open
        If fso.FileExists(dstPath) = False Then
            .LoadFromFile dstPath
            .Position = .Size 'ポインタを終端へ
        End If
        .WriteText line, 1
        .SaveToFile dstPath, 2
        .Close
    End With
 End Sub

（おかもと） 2020/09/04(金) 12:57

ディレクトリ名はバッチ番号、ファイル名は、読み取りファイルを同じ名称でCSV保存ですが
srcPath　に誤りがありそうでしょうか。
（おかもと） 2020/09/04(金) 12:58

 dstPath = dstFolder & "\" & srcFileName

こちらの値は取得できています。
（おかもと） 2020/09/04(金) 13:06

 あっ、ごめんなさい。そこはバグです。
 ファイルがあったら読み込んで、最終位置にするという処理がしたいので、

 If fso.FileExists(dstPath) = True Then

 にしてください。

 リファクタリングでエンバグしました ＞＜。
 （ようは動いた後コードいじって、しくっじったってことです(~_~;)。
　　最終動作確認、大事ですね～～～）
（QS） 2020/09/04(金) 13:34

QS大先生様ありがとうございました～！！！
非常に高速で的確な結果が出力出来ました。
本当に感謝です。

大変恐縮ですが、更に２点ございまして、
ANSIファイルをUTF-8に変換して読み取りをできないかと思います。
システムから出力する際のコードはutf-8になっているようなのですが、
Windowsのメモ帳で開くと、ANSIと表示されています。
UTF-8に変換しないままマクロを実行すると、出力ファイルが文字化けしてしまうので、

Charaset　"ANSI"は引数が違うので、読み込む前にUTF-8に変換させておくマクロを入れると良いでしょうか。

（おかもと） 2020/09/04(金) 20:42

すみません、システム要件を確認したら、SJISで出力したものでいいとのことでしたので、
utf-8をSJISに変えて出力できました！！
本当にありがとうございました！
（おかもと） 2020/09/04(金) 22:13

 自己解決されたようで何よりです。

 一つ気になったのは、分割の個別のファイルはタイトル行は不要でしょうか。

 問題なければよいですが、出力する場合は、下記のような感じで。
 意味を理解しながら修正すれば、個別の追加変更も容易になるかと思います。

 Public headLine
 を先頭に追加。

 For 文の前に
 headLine = lines(0)
 を追加。

 appendLine 内の If 文を
        If fso.FileExists(dstPath) = False Then
            .LoadFromFile dstPath
            .Position = .Size 'ポインタを終端へ
        End If
            .WriteText headLine , 1
        End If
 に変更

（QS） 2020/09/05(土) 11:33

        If fso.FileExists(dstPath) = False Then
            .LoadFromFile dstPath
            .Position = .Size 'ポインタを終端へ
        Else '//    <------- 間違ってました
            .WriteText headLine , 1
        End If
（QS） 2020/09/05(土) 18:40

忘れていましたが、必要でした！
ありがとうございます！！
少しずつでも、調べなくても書けることを目標に勉強を続けていきたいと思います。
ありがとうございました。
（おかもと） 2020/09/06(日) 06:52

コメント返信：

[ 一覧(最新更新順) ]

[[20200830201001]] 『CSVファイルを読み込み、バッチ番号ごとにCSV出力』（おかもと） ページの最後に飛ぶ

[[20200830201001]]　『CSVファイルを読み込み、バッチ番号ごとにCSV出力』（おかもと）　ページの最後に飛ぶ