1364288720 質問です


別添マクロを参考にtxtに保存するときにjun1970とjun1996がうまくできません
うまくできるマクロはありますか

c:\test\のホルダーに複数のCSVファイルがあります
その中のデータのA列2行目から下記データがあります
CSVデータ
jun1970
jun1996
09055556666

結果TXTデータ
1970/06/01
1996/06/01
09055556666
以上の場合
jun1970
jun1996
がうまくできません

何か新しいやり方のマクロでできますか?
参考マクロは別添にあります
よろしくお願いします

回答の条件
  • 1人5回まで
  • 13歳以上
  • 登録:2013/03/26 18:05:20
  • 終了:2013/03/28 17:44:21

ベストアンサー

id:taknt No.1

きゃづみぃ回答回数13539ベストアンサー獲得回数11982013/03/26 18:51:32

ポイント100pt
Sub main()
Dim p As String
'対象フォルダを指定してください。
'このフォルダに この実行用のブックは 入れないでください。

p = "C:\test\"

'処理対象となる拡張子を指定して 呼び出します。
Call jikkou(p, "csv")

End Sub


Sub jikkou(p As String, s As String)

Dim bk() As String
Application.DisplayAlerts = False
    
Dim fdb() As String
    
a = 1
f = Dir(p & "*." & s, vbNormal)
Do While f <> ""
    ReDim Preserve fdb(a)
    fdb(a - 1) = f
    a = a + 1
    f = Dir
Loop



For aaa = 0 To a - 2
    k = 0
    ReDim bk(k)
    f = fdb(aaa)
    f1 = Left(f, Len(f) - 4)
 
    ch1 = FreeFile
    Open p & f For Input As #ch1
 
    Do While Not EOF(ch1)           'ファイルの終端かどうかを確認します
        Line Input #ch1, textline  'データ行を読み込みます
        ReDim Preserve bk(k)
        bk(k) = textline
        k = k + 1
    Loop
    Close #ch1
 
    ch2 = FreeFile
    Open p & f1 + "_softbank.txt" For Output As #ch2
    For i = 0 To k - 1

        textline = bk(i)
        flg = 0
        hai = 0
        moji = ""
        outf = 0
        For c = 1 To Len(textline)
            z = 0
            If Mid(textline, c, 1) = """" Then
                If flg = 0 Then
                    flg = 1
                Else
                    flg = 0
                End If
                z = 1
            End If
            If flg = 0 Then
                If Mid(textline, c, 1) = "," Then
                    hai = hai + 1
                    If hai = 6 Then
                        If Trim(moji) <> "" Then
                            If IsNumeric(moji) Then
                                If CLng(moji) >= 1 And CLng(moji) <= 12 Then
                                    outf = 1
                                End If
                            End If
                        End If
                        Exit For
                    End If
                    z = 1
                    moji = ""
                End If
            End If
            
            If z = 0 Then
                moji = moji & Mid(textline, c, 1)
            End If
        Next c
        
        If outf = 1 Then
            Print #ch2, textline       'データの書き込みをします
        End If
    Next i
    Close #ch2
 
Next aaa

Application.DisplayAlerts = True

End Sub

これだけでいいです。

他32件のコメントを見る
id:taknt

項目の削除と最終列のタブは 関係ないです。

最終列にタブが必要ならば タブを付与するだけです。

textline = Replace(textline,",",vbTab)

textline = Replace(textline,",",vbTab) & vbTab

2013/04/02 16:52:16
id:taknt

コメント欄は 長くなっちゃうと 見づらくなっちゃうので 内容が変わるなら 別の質問にしてもらったほうがいいと思います。

2013/04/02 17:20:32

コメントはまだありません

この質問への反応(ブックマークコメント)

「あの人に答えてほしい」「この質問はあの人が答えられそう」というときに、回答リクエストを送ってみてましょう。

これ以上回答リクエストを送信することはできません。制限について

絞り込み :
はてなココの「ともだち」を表示します。
回答リクエストを送信したユーザーはいません