質問です

c:\test\に複数のCSVファイルがあります
A列1行目からデータがあります。4行おきに1行空白があります

処理前
《名称》あああ
《TEL》088-888-8888
《〒》888-0088
《住所》あああいいいい

《名称》いいい
《TEL》099-999-9999
《〒》999-0099
《住所》いいいうううう

《名称》うううう
《TEL》077-777-7777
《〒》777-0077
《住所》うううええええ


処理後
あああ,088-888-8888,888-0088,あああいいいい
いいい,099-999-9999,999-0099,いいいうううう
うううう,077-777-7777,777-0077,うううええええ

の状態になるマクロをお願いします
《名称》
《TEL》
《〒》
《住所》
の4つを外して4つのカンマ区切りにする
名称,TEL,〒,住所

よろしくお願いします

回答の条件
  • 1人5回まで
  • 13歳以上
  • 登録:2013/06/18 17:54:36
  • 終了:2013/06/19 13:09:58
id:inosisi4141

空白行は削除できます
《名称》
《TEL》
《〒》
《住所》
は外せます
データとしては
あああ
088-888-8888
888-0088
あああいいいい
いいい
099-999-9999
999-0099
いいいうううう
うううう
077-777-7777
777-0077
うううええええ

の状態です
よろしくお願いします

ベストアンサー

id:taknt No.1

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

ポイント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
    
f = Dir(p & "*." & s, vbNormal)

Do While f <> ""
    k = 0
    ReDim bk(k)
 
    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
    moji = ""
    kk = 0
    Open p & f For Output As #ch2
    For i = 0 To k - 1
        textline = bk(i)
        If Trim(textline) <> "" Then
            kk = kk + 1
            If kk > 4 Then
                Print #ch2, moji       'データの書き込みをします
                moji = textline
                kk = 1
            Else
                If moji = "" Then
                    moji = textline
                Else
                    moji = moji & "," & textline
                End If
            End If
        End If
    Next i
    
    If moji <> "" Then
        Print #ch2, moji       'データの書き込みをします
    End If
      
    Close #ch2
 
    f = Dir
Loop


Application.DisplayAlerts = True

End Sub


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

何かありましたら 別に質問だてしてもらったほうが わかりやすいかなと思います。

2013/06/21 14:10:13
id:inosisi4141

ありがとうございました
きゃづみぃさんにご紹介いただいたソフトで
解決いたしました。ありがとうございました。
また何かありもしたらよろしくお願いいたします。

2013/06/21 16:17:51

その他の回答(0件)

id:taknt No.1

きゃづみぃ回答回数13539ベストアンサー獲得回数11982013/06/18 18:56:51ここでベストアンサー

ポイント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
    
f = Dir(p & "*." & s, vbNormal)

Do While f <> ""
    k = 0
    ReDim bk(k)
 
    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
    moji = ""
    kk = 0
    Open p & f For Output As #ch2
    For i = 0 To k - 1
        textline = bk(i)
        If Trim(textline) <> "" Then
            kk = kk + 1
            If kk > 4 Then
                Print #ch2, moji       'データの書き込みをします
                moji = textline
                kk = 1
            Else
                If moji = "" Then
                    moji = textline
                Else
                    moji = moji & "," & textline
                End If
            End If
        End If
    Next i
    
    If moji <> "" Then
        Print #ch2, moji       'データの書き込みをします
    End If
      
    Close #ch2
 
    f = Dir
Loop


Application.DisplayAlerts = True

End Sub


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

何かありましたら 別に質問だてしてもらったほうが わかりやすいかなと思います。

2013/06/21 14:10:13
id:inosisi4141

ありがとうございました
きゃづみぃさんにご紹介いただいたソフトで
解決いたしました。ありがとうございました。
また何かありもしたらよろしくお願いいたします。

2013/06/21 16:17:51

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

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

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

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

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