EXCEL VBAでテキストファイルを読み込み、Spirit関数にて項目内容を書き出す方法

このQ&Aのポイント
  • Excel VBAを使用してテキストファイルを読み込み、Spirit関数を使って項目内容を書き出す方法について教えてください。
  • 日付を1日から31日まで繰り返し処理するコードを作成し、金額A、金額B、金額Cのデータを書き出しています。
  • 現在は15ずつカンマ区切りの位置を変えて1行ずつ書き出していますが、for next文を使ってスッキリとした書き方を教えていただきたいです。
回答を見る
  • ベストアンサー

EXCEL Spirit関数 繰り返し処理

EXCEL VBAでテキストファイルを読み込み、Spirit関数にて項目内容を書き出しています。 下記のコードの日付部分は1日~31日まで繰り返しになります。 Dim maxRow As Integer Dim maxCol As Integer Dim i As Long Dim mytxtfile As String, myStr As String Dim myRange As Range Dim mySp() As String Dim sh1 As Worksheet On Error GoTo myError mytxtfile = "D:\明細.TXT" Set sh1 = Worksheets("元データ") Set myRange = sh1.Range("A1") sh1.Cells.Clear Open mytxtfile For Input As #1 Do Until EOF(1) Line Input #1, myStr myRange.Offset(i, 0).Value = myStr myStr = Replace(myStr, """", "") mySp = Split(myStr, ",") myRange.Offset(i, 1).Value = mySp(0) '卸名 myRange.Offset(i, 2).Value = mySp(1) 'コード myRange.Offset(i, 3).Value = mySp(2) 'フラグ myRange.Offset(i, 4).Value = mySp(6) '納品先 myRange.Offset(i, 5).Value = mySp(7) '店舗 myRange.Offset(i, 6).Value = mySp(23) '日付 ---------ここから myRange.Offset(i, 7).Value = mySp(26) '1日_金額A myRange.Offset(i, 8).Value = mySp(27) '1日_金額B myRange.Offset(i, 9).Value = mySp(34) '1日_金額C --------ここまでが 1日分です。これが31日まで続きます。 i = i + 1 Loop Close #1 '31日までのデータが無い場合のエラーを無視する(データが存在する日まで書き出す) myError: Resume Next sh1.Range("A:A").Delete 'txt取込作業列を削除 End Sub カンマ区切りの位置は、15ずつ増えますので 繰り返し処理したいのですが、うまくいきません。 最初は、金額A だけの書き出しだったため、 1行ずつ書いていたのですが、金額B、Cの列も必要になりました。 for next で すっきりした書き方を教えていただけないでしょうか? 宜しくお願い致します。

質問者が選んだベストアンサー

  • ベストアンサー
  • jcctaira
  • ベストアンサー率58% (119/204)
回答No.1

kochimaru06 さん こんにちは。 以下、修正してみました。ご確認下さい。 ※見やすくするため、勝手に命令を変更しました。   Dim maxCol As Integer   Dim I As Long   Dim J As Long   Dim mytxtfile As String, myStr As String   Dim myRange As Range   Dim mySp() As String   Dim sh1 As Worksheet      Set sh1 = Worksheets("元データ")   Set myRange = sh1.Cells   myRange.Clear   Open mytxtfile For Input As #1   Do Until EOF(1)     Line Input #1, myStr     I = I + 1     myRange(I, "A") = myStr     myStr = Replace(myStr, """", "")     mySp = Split(myStr, ",")        myRange(I, "B") = mySp(0) '卸名     myRange(I, "C") = mySp(1) 'コード     myRange(I, "D") = mySp(2) 'フラグ     myRange(I, "E") = mySp(6) '納品先     myRange(I, "F") = mySp(7) '店舗     myRange(I, "G") = mySp(23) '日付        For J = 0 To 30       On Error Resume Next       myRange(I, 8 + J * 3) = mySp(26 + J * 15) '1~31日_金額A       myRange(I, 9 + J * 3) = mySp(27 + J * 15) '1~31日_金額B       myRange(I, 10 + J * 3) = mySp(34 + J * 15) '1~31日_金額C       On Error GoTo 0     Next J   Loop   sh1.Range("A:A").Delete 'txt取込作業列を削除 End Sube

kochimaru06
質問者

お礼

jcctairaさん、ありがとうございました。 希望どおりの結果が得られました。 EXCEL2003使用の為、元データが列のMAXを超えるので A列に一旦入れて、Split関数を使用して書き出す方法を取りました。 色々と調べて参考にしたコードがDo Loop 使用だったのに、 For Nextで質問してしまい、回答をいただけないかもと不安でした。 (質問を書き直すことが出来なかったので…。) myRange(I, 8 + J * 3) = mySp(26 + J * 15) '1~31日_金額A J*3 J*15 の部分は、J*4 J*15 でも試して確認してみて、 何となく雰囲気がつかめた気がします。 繰り返し処理が、どうしても苦手で…。 避けれないことは分かっているので、少しずつでも理解できる様に頑張ります。 また、Cellsプロパティの列番号は、"A" の様にも指定できたのですね。 とても見やすいので、これからはこちらの方法を使用したいと思います。 本当にありがとうございました。

関連するQ&A

  • エクセルの簡単なマクロ機能を追加したいのです

    既存のエクセルマクロ(Sub チェック()以下です)に下記の内容のマクロを付け足したいです。 教えていただけないでしょうか。 付け足したい条件です:  Sheet2のC列に 0  があれば  Sheet1のB列に 愛 と([太字]でセルの背景色を[灰色25%]にして)入れたいです 恐れ入りますがご存じの方がいらっしゃりましたら教えていただきたく何卒よろしくお願いいたします。 ----------------------------------------------- Sub チェック() Dim Ws1 As Worksheet Dim Ws2 As Worksheet Dim myRange1 As Range Dim myRange2 As Range Dim c1 As Range Dim c2 As Range Dim myCt As Long Set Ws1 = Worksheets("Sheet1") Set Ws2 = Worksheets("Sheet2") Set myRange1 = Ws1.Range("A1", Ws1.Cells(Rows.Count, "A").End(xlUp)) Set myRange2 = Ws2.Range("A1", Ws2.Cells(Rows.Count, "A").End(xlUp)) For Each c1 In myRange1 myCt = 0 For Each c2 In myRange2 If c2.Value = c1.Value Then If c2.Offset(, 1).Value = "" Then c1.Offset(, 1).Interior.ColorIndex = 3 Else c1.Offset(, 1).Value = c2.Offset(, 1).Value End If myCt = myCt + 1 End If Next c2 If myCt > 1 Then c1.Offset(, 1).Interior.ColorIndex = 10 Next c1 Set Ws1 = Nothing Set Ws2 = Nothing Set myRange1 = Nothing Set myRange2 = Nothing End Sub

  • 2007エクセルVBが2013エクセルで動かない

    よろしくお願いします。 エクセル2007VBをエクセル2013に移行して動かしたところ >>>>の部分でエラーが出ました 2007では動いていたのですが、なぜエラーになったのかわかりません。 プログラムは下記の通りです。 Dim iti1 As String Dim ITI2 As String Dim ITI3 As String Dim ITI4 As String Dim ITI5 As String Dim ITI6 As String Dim ITI7 As String Dim ITI8 As String Dim myRange As Range Dim myrange1 As Range Dim answer As Integer Dim c As Double Dim n As Double Workbooks(book1).Activate Sheets("A").Select ITI4 = Range("D65536").End(xlUp).Address '----D列の最終行から上方向の終端セルを選択 Set myRange = Worksheets("A").Range("d6", ITI4) answer = Application.WorksheetFunction.Count(myRange) Set myrange1 = Worksheets("A").Range("g5") For c = 1 To answer 'データー個数のカウント If myrange1.Offset(c) = myday Then n = n + 1 Next     Workbooks(book1).Activate Sheets("A").Select 'コピー座標の取得 iti1 = Range("D65536").End(xlUp).Address '----D列の最終行から上方向の終端セルを選択 ITI7 = Range(iti1).Offset(, 9).Address Range("a5", ITI7).AutoFilter FIELD:=7, Criteria1:=myday ITI2 = Range("M65536").End(xlUp).Address '----M列の最終行から上方向の終端セルを選択 'コードコピー ITI5 = Range(ITI2).Offset(-n + 1, -10).Address '左上のセル>>>>>>>>>ここでアプリケーション定義又はオブジェクトの定義エラーがおこります。 ITI6 = Range(ITI2).Offset(, -9).Address '右下のセル Range(ITI5, ITI6).Copy 'scと銘柄コード貼り付け Workbooks(book3).Activate Sheets("記入").Select ITI3 = Range("c65536").End(xlUp).Address '----C列の最終行から上方向の終端セルを選択 ITI8 = Range(ITI3).Address '終端セルの次を選択 Range(ITI8).Offset(1).PasteSpecial Paste:=xlPasteValues よろしくお願いします。 まだ何本かVBのプログラムがあるのですが移行に際しての注意などがあるサイトがあったら教えてください。

  • VBAの処理を軽くしたい

    各行ごとに5回セルを参照した結果を吐き出すプログラムを作成しています。 200行前後の処理が必要なのですが、現在のコードではあまりにも処理が重くなっています。 とにかく処理を軽くしたいのですが、どのような方法が考えられるでしょうか? 初心者なのでコードも含めてご教示頂けたら幸いです。 Sub test(b, c, d) Dim i1, i2 As Long Dim A1 As String  For i1=0 To Cells(Rows.Count, 1).End(xlUp).Row For i2 = 0 To 5 If Range(b).offset(i1, i2).Value = "x1" Or Range(c).offset(i1, i2).Value = "x1" Then A1 = "XXX" ElseIf Range(b).offset(i1, i2).Value = Range(c).offset(i1, i2).Value Then A1 = "YYY" Else A1 = "ZZZ" End If Range(d).offset(i1, i2).Value = A1 Next i2 Next i1 End Sub

  • 【Excel VBA】チェックボックスの有無

    Excel2003を使用しています。 昨日、『チェックボックスの挿入位置』で質問させていただきましたが、その続きというか、もうひとつ条件を追加したく、改めて質問させていただきます。 Sheet2のN1セルに入力されている番号と同じ番号が入力されているセルをSheet1のA列(A11:A200)から探して、その行のB列にチェックボックスを挿入したく、下記のようにコードを書いています。 ---------------------------------------- Sub test2() Dim myStr As String Dim myRange As Range myStr = Sheets("Sheet2").Range("N1").Value Set myRange = Sheets("Sheet1").Range("A11:A200").Find(myStr) If myRange Is Nothing Then Exit Sub Else Sheets("Sheet1").OLEObjects.Add(ClassType:="Forms.CheckBox.1", Link:=False, DisplayAsIcon:=False, _ Left:=myRange.Offset(, 1).Left , Top:=myRange.Top , Width:=12, Height:=13).Select End If End Sub ---------------------------------------- それで、今回追加したい条件は、既に、チェックボックスが挿入されていた場合は、何もせずに処理を終えたいのです。 現在は、チェックボックスが挿入されていると、そのチェックボックスの上に新たに重なってしまいますので、そうならないようにできたらと思い、質問させていただきました。 よろしくお願いします。

  • VBAでセルのコピーをすると、エラーになる

    =IF(COUNTIF('5月'!B4:I13,E13)=0,"",COUNTIF('5月'!I:I,E13))というセルを コピーして、別のシートのセルに貼り付けたのですが、値が「0」の場合「””」が セルに張り付いてしまい、その後の計算ができません。 「””」を本当の空欄にするにはどうしたらいいのでしょうか? Sub 転記() Dim sh1 As Worksheet Dim sh2 As Worksheet Dim SN As String SN = Month(Now()) Set sh1 = Sheets(SN) Set sh2 = Sheets("差出票") sh1.Range("A35").End(xlUp).Offset(1) = sh2.Range("B9") sh1.Range("A35").End(xlUp).Offset(0, 1) = sh2.Range("F13") sh1.Range("A35").End(xlUp).Offset(0, 2) = sh2.Range("F14") sh1.Range("A35").End(xlUp).Offset(0, 3) = sh2.Range("F15") sh1.Range("A35").End(xlUp).Offset(0, 4) = sh2.Range("F16") sh1.Range("A35").End(xlUp).Offset(0, 5) = sh2.Range("F17") sh1.Range("A35").End(xlUp).Offset(0, 6) = sh2.Range("F18") sh1.Range("A35").End(xlUp).Offset(0, 7) = sh2.Range("F19") End Sub

  • アクセスへのエクセルファイルの一括取込みについて

    お世話になっております。 エクセルVBAで所定のフォルダのエクセルファイルから一つのシートにまとめるというマクロを作成しております。アクセスVBAでaccdbファイルで同じことをしたいのですが、アクセスは触ったことがなく、ご教示していただけないでしょうか。 以下エクセルでの取り込みマクロです(長いので一部割愛)。 ーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーー Sub エクセル取り込み() Dim fpath, fname, buzai, bmst, hantei As String Dim buzaiflg As Boolean Dim wb As Workbook Dim sh1, sh2, sh3, sh4, sh5 As Worksheet Dim dlg As FileDialog Dim TCht As Chart Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Application.EnableEvents = False Set sh1 = ThisWorkbook.Worksheets("データまとめ") Set dlg = Application.FileDialog(msoFileDialogFolderPicker) ' キャンセルボタンクリック時にマクロを終了 If dlg.Show = False Then Exit Sub ' フォルダーのフルパスを変数に格納 fpath = dlg.SelectedItems(1) & "\" Application.DisplayAlerts = False i = 5 pcnt = 2 fname = Dir(fpath & "*.xl*", vbNormal) Do Until fname = "" Set wb = Workbooks.Open(fpath & fname, UpdateLinks:=0) Set sh2 = wb.Worksheets(1) i = i + 1 sh1.Range("A" & i).Value = i - 5 sh1.Range("B" & i).Value = fname sh1.Range("C" & i).Value = sh2.Range("A6").Value sh1.Range("D" & i).Value = sh2.Range("D6").Value sh1.Range("E" & i).Value = sh2.Range("F6").Value sh1.Range("F" & i).Value = sh2.Range("K4").Value sh1.Range("G" & i).Value = sh2.Range("K5").Value sh1.Range("H" & i).Value = sh2.Range("A9").Value 割愛 wb.Close SaveChanges:=False fname = Dir() Loop Application.ScreenUpdating = True Application.DisplayAlerts = True Application.Calculation = xlCalculationAutomatic Application.EnableEvents = True MsgBox "終了しました。" End Sub

  • 【Excel VBA】チェックボックスの挿入位置

    Excel2003を使用しています。 Sheet2のN1セルに入力されている番号と同じ番号が入力されているセルをSheet1のA列(A11:A200)から探して、その行のB列にチェックボックスを挿入したく、下記のようにコードを書いてみましたが、チェックボックスの挿入と挿入位置等(?部分)をどのように書いたらいいのかわかりません。 ---------------------------------------- Sub test1() Dim myStr As String Dim myRange As Range myStr = Sheets("Sheet2").Range("N1").Value Set myRange = Sheets("Sheet1").Range("A11:A200").Find(myStr) If myRange Is Nothing Then Exit Sub Else  '?←この部分がわかりません…。 End If End Sub ---------------------------------------- 実際にチェックボックスを挿入してマクロの記録もとってみたのですが、あまり参考にすることができず、質問させていただいた次第です。 チェックボックスは、コントロールツールボックスのチェックボックスを使用したいのですが…。 よろしくお願いします。

  • エクセル 複数シート( VLOOKUP ユーザー定義関数

    複数シート(範囲)を指定できるVLOOKUP関数をユーザー定義で作りたいと思ってます。下記のコードではうまく動かないので教えてください。 Function VLOOKUPM(検索値 As Variant, 対象シート As String, 対象セル As Range, 列番号 As Integer) As Variant Dim i As Integer Dim r As Range Dim sh As Variant Application.Volatile sh = Split(対象シート, ",") For i = 0 To UBound(sh) Set r = Sheets(sh(i)).Range(対象セル) If 検索値 = r Then VLOOKUPM = r.Offset(0, 列番号) Exit Function End If Next End Function

  • excel vbaでの質問になります

    このようなマクロを作成したのですが、セルに数式が入れてあると、どうしてもその下の空白の行に値を入力されてしまいます。 数式が入っているセルにもそのままセルに値を入れたいのですが・・ 宜しくお願いします。 Dim wb1 As Worksheet, r1 As Range Dim N As Integer, i As Integer Dim mycount As Long   Set wb1 = ThisWorkbook.Worksheets("請求書") mycount = Range("B111").CurrentRegion.Rows.Count Cells(111 + mycount, 2).Select ActiveCell.Offset(0, 0).Value = wb1.Range("C60").Value ActiveCell.Offset(0, 1).Value = wb1.Range("C61").Value ActiveCell.Offset(0, 12).Value = wb1.Range("C66").Value ActiveCell.Offset(0, 13).Value = wb1.Range("C74").Value ActiveCell.Offset(0, 14).Value = wb1.Range("C75").Value ActiveCell.Offset(0, 15).Value = wb1.Range("C84").Value ActiveCell.Offset(0, 16).Value = wb1.Range("C85").Value ActiveCell.Offset(0, 20).Value = wb1.Range("C69").Value ActiveCell.Offset(0, 22).Value = wb1.Range("C68").Value ActiveCell.Offset(0, 23).Value = wb1.Range("C76").Value ActiveCell.Offset(0, 24).Value = wb1.Range("C77").Value Exit Sub

  • Excel UserForm ListBox

    Excel UserForm ListBoxの表示についての質問です Sheets("加工").Range("A44")からRange("G" & LastRow)のセルの値を Form_receipt.ListBox1に表示させたいのですが C~E列は数値なので桁数区切りで表示したくてマクロを作ったのですが A列1列しか表示されないマクロになってしまいました。 どこが悪いのかご教示願えませんか? あわせてC~E列を右揃えでリスト表示する方法も教えてください 失敗作のマクロは以下です Sub Macro48() Form_receipt.ListBox1.Clear Sheets("加工").Select '配列の定義 Dim myRng As Range Dim myList As Variant Dim c As Variant Dim i As Integer Dim j As Integer Dim LastRow As Integer For j = 45 To 94 If Sheets("加工").Range("A" & j).Value = "" Then Exit For End If Next j If Sheets("加工").Range("A47").Value = "" Then LastRow = j - 1 Else LastRow = 46 End If Set myRng = Range("A44", Range("A" & LastRow)) ReDim myList(myRng.Rows.Count - 1, 7) For Each c In myRng myList(i, 0) = c.Offset(, 0).Value myList(i, 1) = c.Offset(, 1).Value myList(i, 2) = Format$(c.Offset(, 2).Value, "@@@,@@@,@@@") myList(i, 3) = Format$(c.Offset(, 3).Value, "@@@,@@@,@@@") myList(i, 4) = Format$(c.Offset(, 4).Value, "@@@,@@@,@@@") myList(i, 5) = c.Offset(, 5).Value myList(i, 6) = c.Offset(, 6).Value myList(i, 7) = c.Offset(, 7).Value i = i + 1 Next c Form_receipt.ListBox1.List() = myList Set myRng = Nothing 'リスト表示幅設定 With Form_receipt.ListBox1 .ColumnWidths = "30,0,60,60,60,150,50" End With Form_receipt.Show End sub

専門家に質問してみよう