次の動作をするExcel(エクセル)2007のVBA(マクロ)コードを教えていただきたいです。



【Sheet2】の【A列】、【B列】、【E列】、【F列】、【G列】、【H列】、【I列】を1行ごとにセットとして、テキストファイルに出力したいです。

また、テキストファイル出力するときは
列ごとに特定の順番があり、列によっては後ろに特定の文字列をくっつける仕様になります。



(※長くなってしまったので、具体的な「続き」を、このページ下部の「コメント」欄に書かせていただきます。
よろしくおねがいします。)

回答の条件
  • 1人3回まで
  • 13歳以上
  • 登録:2014/10/08 02:22:23
  • 終了:2014/10/08 21:54:13

ベストアンサー

id:cx20 No.1

cx20回答回数604ベストアンサー獲得回数1072014/10/08 04:22:13

ポイント1000pt

Excel VBA でなく VBScript ですがよろしいでしょうか。
(以前、似たような質問(http://q.hatena.ne.jp/1320812779)があったので、それを少し修正したものになります。)

デスクトップにフォルダを作成する機能は、眠くなってきたので未実装です。すみません。。。
出力先ファイルパスの変数(g_strOutputFile)を修正してご利用ください。

本プログラムは、ADO というライブラリを使用した Excel データアクセスのサンプルプログラムになります。
SQL をご存じであれば、Excel データを DB のようにアクセスすることが可能です。

A B C D E F G H I
001horse 180 25 60微妙な人間の表情を読み取れる
002dog 50 15 50飼い主に従順
003ゾウelephant600 55 40個体差があり、気性が荒かったり従順だったりする
010馬2 horse2 微妙な人間の表情を読み取れる

ヘッダ行が無い場合は、A列…F1、B列…F2、...、I列…F9のように扱うことができます。

' File : ExcelToReportText.vbs
' Usage : CScript //Nologo ExcelToReportText.vbs
Option Explicit

' Excelファイルを指定します
Const g_strExcelFile = "C:\home\edu\hatena\egaosaiko\1412702543\Book1.xlsx"
' 出力先のファイルパスを指定します
Const g_strOutputFile = "C:\home\edu\hatena\egaosaiko\1412702543\output\出力データ.txt"

Call Main()

Sub Main()
    ' Excel ファイルの内容を指定したパスにテキストファイル出力する
    Call ConvertExcelToReportTextFile( g_strExcelFile, g_strOutputFile )
End Sub

' Excel ファイルの内容を指定したパスにテキストファイル出力する
Sub ConvertExcelToReportTextFile( strFileName, strOutputFile )
    Dim cn
    Set cn = CreateObject("ADODB.Connection")
    
    ' Excel 97-2003 であれば、以下を有効化します。
    'cn.Open "PROVIDER=Microsoft.Jet.OLEDB.4.0;Data Source=" & strFileName & ";Extended Properties=""Excel 8.0;HDR=No;"""
    ' Excel 2007/2010 の場合は、以下を有効化します。
    cn.Open "PROVIDER=Microsoft.ACE.OLEDB.12.0;Data Source=" & strFileName & ";Extended Properties=""Excel 12.0;HDR=No;"""
    
    Dim rs
    '+---+----+---+---+--------+---+---+---+----------------------------------------------+
    '| A |B   |C  |D  |E       |F  |G  |H  |I                                             |
    '+---+----+---+---+--------+---+---+---+----------------------------------------------+
    '|001|馬  |   |   |horse   |180| 25| 60|微妙な人間の表情を読み取れる                  |
    '|002|犬  |   |   |dog     | 50| 15| 50|飼い主に従順                                  |
    '|003|ゾウ|   |   |elephant|600| 55| 40|個体差があり、気性が荒かったり従順だったりする|
    '|010|馬2 |   |   |horse2  |   |   |   |微妙な人間の表情を読み取れる                  |
    '+---+----+---+---+--------+---+---+---+----------------------------------------------+
    '  :   :    :   :     :      :   :   :   :
    ' F1  F2   F3  F4    F5     F6  F7  F8  F9
    '
    ' SELECT F1, F2, F5, F6, F7, F8, F9 FROM [Sheet2$]
    Set rs = cn.Execute("SELECT F1, F2, F5, F6, F7, F8, F9 FROM [Sheet2$]")
    
    Dim strReportText
    Dim strBaseName
    Dim strTextFile
    Dim nLines
    nLines = 11
    ' レコード件数分、順次取得します
    While Not rs.BOF And Not rs.EOF
        ' レコードセットにある情報をレポートテキストとして取得
        strReportText = GetReportTextFromRecordset( rs, nLines )
        ' レポートテキストをファイル出力
        Call WriteReportTextToFile( strReportText, strOutputFile )
        strTextFile = strTextFile & strReportText
        ' 次のレコードに移動
        rs.MoveNext
    Wend
End Sub

' レコードセットの内容をレポートテキストとして取得する
Function GetReportTextFromRecordset( rs, nLines )
    Dim strResult
    
    Dim str
    Dim strValue
    
    Dim fld

    Dim nLine
    nLine = 0
    Dim strFieldValue
    For Each fld In rs.Fields
        strFieldValue = GetFieldValueWithAddInfo(fld)
        If strFieldValue <> "" Then
            'デバッグ用
            'strResult = strResult & (nLine+1) & ":" & strFieldValue & vbCrLf
            strResult = strResult & strFieldValue & vbCrLf
            nLine = nLine + 1 ' 処理した件数ぶんカウントアップ
        End If
    Next
    
    Dim i
    ' 指定行数まで改行を追加する
    For i = nLine + 1 To nLines
        strResult = strResult & vbCrLf
    Next
    
    GetReportTextFromRecordset = strResult
End Function

' フィールドデータに追加情報を付与して返却する
Function GetFieldValueWithAddInfo( fld )
    Dim strResult
    strResult = ""
    '+---+----+---+---+--------+---+---+---+----------------------------------------------+
    '| A |B   |C  |D  |E       |F  |G  |H  |I                                             |
    '+---+----+---+---+--------+---+---+---+----------------------------------------------+
    '|001|馬  |   |   |horse   |180| 25| 60|微妙な人間の表情を読み取れる                  |
    '|002|犬  |   |   |dog     | 50| 15| 50|飼い主に従順                                  |
    '|003|ゾウ|   |   |elephant|600| 55| 40|個体差があり、気性が荒かったり従順だったりする|
    '|010|馬2 |   |   |horse2  |   |   |   |微妙な人間の表情を読み取れる                  |
    '+---+----+---+---+--------+---+---+---+----------------------------------------------+
    '  :   :    :   :     :      :   :   :   :
    ' F1  F2   F3  F4    F5     F6  F7  F8  F9
    '
    Dim strAddInfo
    ' 列に応じて追加情報を取得する
    Select Case fld.Name
       Case "F6"
          strAddInfo = "cm"
       Case "F7"
          strAddInfo = "歳くらい"
       Case "F8"
          strAddInfo = "km/時"
    End Select
    
    ' フィールドデータがブランクでなければ情報を付与する
    If Not IsNull(fld.Value) And Not IsEmpty(fld.Value) Then
       strResult = fld.Value & strAddInfo
    End If
    
    GetFieldValueWithAddInfo = strResult
End Function


' データをファイル出力する
Function WriteReportTextToFile( strReportText, strOutputFile )
    Dim fso
    Set fso = CreateObject("Scripting.FileSystemObject")
    
    Dim strFileName
    strFileName = strOutputFile
    
    Dim file
    Set file = fso.OpenTextFile(strFileName, 8, True) ' 追加書き込みモード
    
    ' デバッグ用
    'WScript.Echo "[" & strFileName & "]"
    'WScript.Echo strReportText
    'WScript.Echo ""
    
    file.Write strReportText
    file.Close
End Function
他1件のコメントを見る
id:cx20

> VBScriptという言葉も今回はじめて聞いたくらいでして。

大変、失礼致しました。

ひらたく説明すると VBScript は VBA の兄弟のようなものです。
・Excel VBA … Excel に付属している Basic 言語。Excel の機能を直接呼び出すことが可能。
・VBScript … Windows OS に付属している Basic 言語。Excel の機能を間接的に呼び出すことが可能。
と言った感じです。

<参考情報>
■ VBScript 基礎文法最速マスター
http://vbscript.g.hatena.ne.jp/cx20/20100131/1264906231

> 教えていただいたコードはどこに貼り付けたらいいのか、

本サンプルは、「ExcelToReportText.vbs」という名前で保存して頂き、
コマンドプロンプトより「CScript ExcelToReportText.vbs」と入力することにより実行することが可能です。

また、VBScript のソースコードの大半は、VBA でも利用可能です。実行される場合は以下の手順を参照ください。
----------------------------------------------
1. 本サンプルを VBA の編集画面に貼り付ける
2. 「Call Main」の行をコメントアウトする。
3. 「Sub Main()」を実行する。
→ プログラムが実行され「出力データ.txt」が生成される。
----------------------------------------------

2014/10/09 00:38:36
id:egaosaiko


cx20さんへ

物知らぬ私に、とても分かりやすくご説明いただきありがとうございます。


参考URLも教えていただき、ありがたいです。
ブックマークさせていただきました。


VBScriptの実行方法は、今の私にはいくら考えても分からないやり方だったんですね(笑い)!
Basic言語を書ける方(私の拙い日本語をプログラム化で表現できる方)は、単純に神々しく見えます。


私も少しずつVBAが書けるようになりたいです。

2014/10/09 01:32:28
  • id:egaosaiko
    (ここまで見ていただいてありがとうございます。)


    具体的に言いますと、


    【Sheet2】において、
    1行目から(2行目、3行目と・・)【A列】、【B列】、【E列】、【F列】、【G列】、【H列】、【I列】それぞれにデータが入っているのですが、
    この1行ずつを7行のひと塊として、テキストファイルに出力したいです。

    そして、次の1行(2行目)は4行改行した後に出力します。
    さらに次の1行(3行目)は、また4行改行した後に出力していく、という繰り返しを
    【Sheet2】のデータが入っている行まで行いたいのです。



    テキストファイルは、以下のように出力します。
    ↓↓↓
    ----------------------------------------------------------------------------
    A列1行目
    B列1行目
    E列1行目
    F列1行目 + 文字列の「cm」
    G列1行目 + 文字列の「歳くらい」
    H列1行目 + 文字列の「km/時」
    I列1行目




    A列2行目
    B列2行目
    E列2行目
    F列2行目 + 文字列の「cm」
    G列2行目 + 文字列の「歳くらい」
    H列2行目 + 文字列の「km/時」
    I列21行目




    A列3行目
    B列3行目
    E列3行目
    F列3行目 + 文字列の「cm」
    G列3行目 + 文字列の「歳くらい」
    H列3行目 + 文字列の「km/時」
    I列3行目
     ・
     ・
     ・
    ----------------------------------------------------------------------------
    ↑↑
    ※「A列1行目」は【A1】のことです。
    同じように、
    「A列2行目」は【A2】、「A列3行目」は【A3】を指します。




    例えば、
    【Sheet2】に以下のようなデータが存在するとします。
     ↓↓↓

    ----------------------------------------------------------------------------
    Excel2007の【Sheet2】
    ----------------------------------------------------------------------------
    A1:001
    B1:馬
    E1:horse
    F1:180
    G1:25
    H1:60
    I1:微妙な人間の表情を読み取れる


    A2:002
    B2:犬
    E2:dog
    F2:50
    G2:15
    H2:50
    I2:飼い主に従順


    A3:003
    B3:ゾウ
    E3:elephant
    F3:600
    G3:55
    H3:40
    I3:個体差があり、気性が荒かったり従順だったりする
    ----------------------------------------------------------------------------

    これらをテキストファイルに出力すると、
     ↓↓↓


    ----------------------------------------------------------------------------
    テキストファイル名:出力データ.txt
    ----------------------------------------------------------------------------
    001

    horse
    180cm
    25歳くらい
    60km/時
    微妙な人間の表情を読み取れる




    002

    dog
    50cm
    15歳くらい
    50km/時
    飼い主に従順




    003
    ゾウ
    elephant
    600cm
    55歳くらい
    40km/時
    個体差があり、気性が荒かったり従順だったりする
    ----------------------------------------------------------------------------


    という結果になれば成功です。

    【F列】、【G列】、【H列】はそれぞれ後ろに文字列を付けて出力するようにします。
     ↓↓↓
    【F列】 + 文字列の「cm」
    【G列】 + 文字列の「歳くらい」
    【H列】 + 文字列の「km/時」

    ※実際に「cm」、「歳くらい」、「km/時」という文字列それぞれを、そのまま【F列】、【G列】、【H列】に使いたいです。



    それから、出力する場所と方法についてなのですが、
    デスクトップにフォルダ名「出力データフォルダ」というフォルダを自動生成し、
    その中に、【Sheet2】の内容を出力したテキストファイル(テキストファイル名「出力データ.txt」)を自動生成するようにしたいのですが可能でしょうか。


    また、
    すでにデスクトップに「出力データフォルダ」が存在するときは、
    フォルダも、その中のテキストファイルも同じ名前のまま上書きする仕様だと理想的です。
    (「出力データフォルダ」をそのまま残して、その中のすでに存在している「出力データ.txt」を削除してから、新しい「出力データ.txt」だけを生成して残していく、といったイメージです。)




    ※(補足なのですが)
    【Sheet2】の【A列】、【B列】、【E列】、【F列】、【G列】、【H列】、【I列】の中で空白のセルがあった場合は
    テキストファイル出力の際、その空白のセル分を上に詰めて出力していただけると嬉しいです。

    例です。
    ----------------------------------------------------------------------------
    Excel2007の【Sheet2】
    ----------------------------------------------------------------------------
    A1:001
    B1:馬
    E1:horse
    F1:
    G1:
    H1:
    I1:微妙な人間の表情を読み取れる
    ----------------------------------------------------------------------------
     ↓↓↓

    ----------------------------------------------------------------------------
    テキストファイル名:出力データ.txt
    ----------------------------------------------------------------------------
    001

    horse
    微妙な人間の表情を読み取れる
    ----------------------------------------------------------------------------





    ※説明がかなりややこしいと思いますので、
    何か分かりにくいところがありましたら、
    このページでコメントをお願いします。

  • id:Yoshiya
    Sub Sample()

    Dim WritePath As String
    Dim FileName As String
    Dim FileNo
    Dim WSH As Variant

    Dim MaxRow As Long
    Dim WriteStr As String
    Dim lp1 As Long
    Dim lp2 As Integer

    Set WSH = CreateObject("Wscript.Shell")

    On Error Resume Next
    WritePath = WSH.SpecialFolders("Desktop") & "\\出力データフォルダ"
    MkDir WritePath
    On Error GoTo 0

    FileName = "出力データ.txt"
    FileNo = FreeFile
    Open WritePath & "\\" & FileName For Output As #FileNo

    Worksheets("Sheet2").Select
    MaxRow = Range("A1").End(xlDown).Row - 1
    For lp1 = 0 To MaxRow
    For lp2 = 0 To 8
    If lp2 <> 2 And lp2 <> 3 Then
    If Range("A1").Offset(lp1, lp2) <> "" Then
    Select Case lp2
    Case 0 To 4
    WriteStr = Range("A1").Offset(lp1, lp2)
    Case 5
    WriteStr = Range("A1").Offset(lp1, lp2) & "cm"
    Case 6
    WriteStr = Range("A1").Offset(lp1, lp2) & "歳くらい"
    Case 7
    WriteStr = Range("A1").Offset(lp1, lp2) & "km/時"
    Case 8
    WriteStr = Range("A1").Offset(lp1, lp2)
    End Select

    Print #FileNo, WriteStr
    Else
    Print #FileNo, vbCrLf
    End If
    End If
    Next lp2

    Print #FileNo, vbCrLf & vbCrLf & vbCrLf
    Next lp1

    Close #FileNo
    Set WSH = Nothing

    End Sub

    一応動作確認は行いました。
  • id:egaosaiko
    Yoshiyaさんへ


    いつも長い説明文を読んでいただき、
    コードを考えて書いて下さりありがとうございます。


    さっそくコードを試させていただきました。

    私がしたいことを見事に実現してくれました。
    ありがたいです。



    ただ、
    2つほど気になった部分があったのですが意見してよろしいでしょうか。



    ●私の説明文をまた使わせていただくのですが、
    以下のように
     ↓↓↓

    例です。
    ----------------------------------------------------------------------------
    Excel2007の【Sheet2】
    ----------------------------------------------------------------------------
    A1:001
    B1:馬
    E1:horse
    F1:
    G1:
    H1:
    I1:微妙な人間の表情を読み取れる
    ----------------------------------------------------------------------------

     ↓↓↓

    ----------------------------------------------------------------------------
    テキストファイル名:出力データ.txt
    ----------------------------------------------------------------------------
    001

    horse
    微妙な人間の表情を読み取れる
    ----------------------------------------------------------------------------


    【Sheet2】の【A列】、【B列】、【E列】、【F列】、【G列】、【H列】、【I列】の中で空白のセルがあった場合は
    テキストファイル出力の際、その空白のセル分を上に詰めて出力していただけると嬉しいです。



    ●また、
    【Sheet2】のデータが0行(1行もデータがない状態)、もしくは1行だけのときに実行すると
    エクセル2007(Excel2007)が固まってしまう(テキストファイルを永遠に改行し続ける)のですが、
    これは修正可能でしょうか?



    大変お手数おかけしますが、
    もし可能でしたら教えていただきたいです。


  • id:Yoshiya
    ヘンリ様

    上記のご指摘の点を修正しました。

    修正1)セルの行数を予め調べる場合(0行の場合は即終了)

    Sub Sample()

    Dim WritePath As String
    Dim FileName As String
    Dim FileNo
    Dim WSH As Variant

    Dim MaxRow As Long
    Dim WriteStr As String
    Dim lp1 As Long
    Dim lp2 As Integer

    Set WSH = CreateObject("Wscript.Shell")

    On Error Resume Next
    WritePath = WSH.SpecialFolders("Desktop") & "\\出力データフォルダ"
    MkDir WritePath
    On Error GoTo 0

    FileName = "出力データ.txt"
    FileNo = FreeFile
    Open WritePath & "\\" & FileName For Output As #FileNo

    Worksheets("Sheet2").Select
    MaxRow = Cells(Rows.Count, 1).End(xlUp).Row - 1
    If MaxRow = 0 Then
    Exit Sub
    End If

    For lp1 = 0 To MaxRow
    For lp2 = 0 To 8
    If lp2 <> 2 And lp2 <> 3 Then
    If Range("A1").Offset(lp1, lp2) <> "" Then
    Select Case lp2
    Case 0 To 4
    WriteStr = Range("A1").Offset(lp1, lp2)
    Case 5
    WriteStr = Range("A1").Offset(lp1, lp2) & "cm"
    Case 6
    WriteStr = Range("A1").Offset(lp1, lp2) & "歳くらい"
    Case 7
    WriteStr = Range("A1").Offset(lp1, lp2) & "km/時"
    Case 8
    WriteStr = Range("A1").Offset(lp1, lp2)
    End Select

    Print #FileNo, WriteStr
    End If
    End If
    Next lp2

    Print #FileNo, vbCrLf & vbCrLf & vbCrLf
    Next lp1

    Close #FileNo
    Set WSH = Nothing

    End Sub


    修正2)A列のセルが空行の場合、処理を終了する場合

    Sub Sample()

    Dim WritePath As String
    Dim FileName As String
    Dim FileNo
    Dim WSH As Variant

    Dim WriteStr As String
    Dim lp1 As Long
    Dim lp2 As Integer

    Set WSH = CreateObject("Wscript.Shell")

    On Error Resume Next
    WritePath = WSH.SpecialFolders("Desktop") & "\\出力データフォルダ"
    MkDir WritePath
    On Error GoTo 0

    FileName = "出力データ.txt"
    FileNo = FreeFile
    Open WritePath & "\\" & FileName For Output As #FileNo

    Worksheets("Sheet2").Select

    lp1 = 0
    Do While Range("A1").Offset(lp1, 0) <> ""
    For lp2 = 0 To 8
    If lp2 <> 2 And lp2 <> 3 Then
    If Range("A1").Offset(lp1, lp2) <> "" Then
    Select Case lp2
    Case 0 To 4
    WriteStr = Range("A1").Offset(lp1, lp2)
    Case 5
    WriteStr = Range("A1").Offset(lp1, lp2) & "cm"
    Case 6
    WriteStr = Range("A1").Offset(lp1, lp2) & "歳くらい"
    Case 7
    WriteStr = Range("A1").Offset(lp1, lp2) & "km/時"
    Case 8
    WriteStr = Range("A1").Offset(lp1, lp2)
    End Select

    Print #FileNo, WriteStr
    End If
    End If
    Next lp2
    lp1 = lp1 + 1
    Loop

    Print #FileNo, vbCrLf & vbCrLf & vbCrLf

    Close #FileNo
    Set WSH = Nothing

    End Sub
  • id:egaosaiko
    Yoshiya 様へ


    何度もお付き合いいただきまして、
    ありがとうございます。



    さっそく修正していただきましたコードを実行させていただきました。
    それも2パターンも考慮していただき、ありがたいです。


    どちらのパターンも【Sheet2】が0行のときでも、
    Excelが固まらない仕様にしていただき、とても助かります。



    両パターン、いろいろな場面で試させていただきまして
    気づいたことがありますので、また意見させていただいてもよろしいでしょうか。



    ●修正1)セルの行数を予め調べる場合(0行の場合は即終了)
    ↑↑
    こちらのコードだと、
    【Sheet2】が1行だった場合にはテキストファイルに何も出力されないので、
    1行だった場合でも出力できるようにしていただくことは可能でしょうか?


    また、【Sheet2】が0行の場合と1行の場合にのみ、再度実行すると、

    【実行時エラー '55':
    ファイルは既に開かれています。】

    という窓が開くのですが、これが出ないようにすることが出来ましたら嬉しいです。



    ●修正2)A列のセルが空行の場合、処理を終了する場合
    ↑↑
    こちらのコードだと、
    【Sheet2】が1行の場合でも、テキストファイルに出力してくれるのでありがたいです。

    ただ、【Sheet2】が2行以上の場合に実行すると分かるのですが、
    最後だけ4行分改行してくれるのですが、途中は改行してくれないのでここを修正していただけましたら助かります。




    幾度も申し訳ございません。
    もし手が空いておりましたら、どうかよろしくお願いいたします。

  • id:Yoshiya
    ヘンリさま

    度々の不具合、ご迷惑をおかけして申し訳ありません。

    修正1)

    Sub Sample()

    Dim WritePath As String
    Dim FileName As String
    Dim FileNo
    Dim WSH As Variant

    Dim MaxRow As Long
    Dim WriteStr As String
    Dim lp1 As Long
    Dim lp2 As Integer

    Set WSH = CreateObject("Wscript.Shell")

    On Error Resume Next
    WritePath = WSH.SpecialFolders("Desktop") & "\\出力データフォルダ"
    MkDir WritePath
    On Error GoTo 0

    FileName = "出力データ.txt"
    FileNo = FreeFile
    Open WritePath & "\\" & FileName For Output As #FileNo

    Worksheets("Sheet2").Select
    MaxRow = Cells(Rows.Count, 1).End(xlUp).Row - 1
    If MaxRow > 0 Then
    Close #FileNo
    Set WSH = Nothing
    Exit Sub
    End If

    For lp1 = 0 To MaxRow
    For lp2 = 0 To 8
    If lp2 <> 2 And lp2 <> 3 Then
    If Range("A1").Offset(lp1, lp2) <> "" Then
    Select Case lp2
    Case 0 To 4
    WriteStr = Range("A1").Offset(lp1, lp2)
    Case 5
    WriteStr = Range("A1").Offset(lp1, lp2) & "cm"
    Case 6
    WriteStr = Range("A1").Offset(lp1, lp2) & "歳くらい"
    Case 7
    WriteStr = Range("A1").Offset(lp1, lp2) & "km/時"
    Case 8
    WriteStr = Range("A1").Offset(lp1, lp2)
    End Select

    Print #FileNo, WriteStr
    End If
    End If
    Next lp2

    Print #FileNo, vbCrLf & vbCrLf & vbCrLf
    Next lp1

    Close #FileNo
    Set WSH = Nothing

    End Sub

    修正2)

    Sub Sample()

    Dim WritePath As String
    Dim FileName As String
    Dim FileNo
    Dim WSH As Variant

    Dim WriteStr As String
    Dim lp1 As Long
    Dim lp2 As Integer

    Set WSH = CreateObject("Wscript.Shell")

    On Error Resume Next
    WritePath = WSH.SpecialFolders("Desktop") & "\\出力データフォルダ"
    MkDir WritePath
    On Error GoTo 0

    FileName = "出力データ.txt"
    FileNo = FreeFile
    Open WritePath & "\\" & FileName For Output As #FileNo

    Worksheets("Sheet2").Select

    lp1 = 0
    Do While Range("A1").Offset(lp1, 0) <> ""
    For lp2 = 0 To 8
    If lp2 <> 2 And lp2 <> 3 Then
    If Range("A1").Offset(lp1, lp2) <> "" Then
    Select Case lp2
    Case 0 To 4
    WriteStr = Range("A1").Offset(lp1, lp2)
    Case 5
    WriteStr = Range("A1").Offset(lp1, lp2) & "cm"
    Case 6
    WriteStr = Range("A1").Offset(lp1, lp2) & "歳くらい"
    Case 7
    WriteStr = Range("A1").Offset(lp1, lp2) & "km/時"
    Case 8
    WriteStr = Range("A1").Offset(lp1, lp2)
    End Select

    Print #FileNo, WriteStr
    End If
    End If
    Next lp2
    Print #FileNo, vbCrLf & vbCrLf & vbCrLf
    lp1 = lp1 + 1
    Loop

    Close #FileNo
    Set WSH = Nothing

    End Sub

  • id:egaosaiko
    Yoshiya 様へ


    大変お世話になっております。
    こちらこそ、何度も私のわがままを聞いて下さりありがとうございます。



    こんなに早く修正コードを2パターン分教えて下さり、ありがたいです。

    さっそく、修正されたVBAコードを使わせていただきたいと思います。


    Yoshiyaさん、
    重ね重ねありがとうございます。

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

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

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

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