VBAでタブ区切りで出力する方法

このQ&Aのポイント
  • エクセルのデータをタブ区切りで出力するVBAのコードを作成したが、タイトル行およびサンプル行を削除する処理を追加したら正しく出力されなくなった。
  • タイトル行およびサンプル行を削除する前のVBAコードでは、タブ区切りで出力ができた。
  • 正しくタブ区切りで出力するために、どの列にデータが入るべきなのかを判断する方法がわからない。
回答を見る
  • ベストアンサー

VBAで””なしのタブ区切りで出力する方法

エクセルのデータをタブ区切りで出力したいのですが、「ファイル名を付けて保存」から「ファイルの種類」をタブ区切りにして保存した場合、カンマが含まれるセルにダブルクォーテーション「””」が付与されてしまいます。 やりたいことは以下の3つになります。 1.タブ区切りで出力する 2.カンマが含まれていてもダブルクォーテーションで括らない 3.先頭2行(1行目と2行目)を削除 ※1行目はタイトル行、2行目はサンプル行です。 1と2を満たすVBAはできたのですが、3を実現するために以下の 処理を加えたところ、正しくタブ区切りで出力されなくなってしまいました。 ・アクティブシートをコピー ・1~2行目を削除 ・コピーしたシートを削除 作成したVBAは以下になります。 ーーーーーーーここからーーーーーーーーーーーー Option Explicit Public Sub ChangeTSV() Dim FileName As String FileName = WriteTsvFile(ActiveSheet) If FileName <> "" Then MsgBox "タブ区切りテキストファイルが作成されました。" & vbCrLf & "[PATH]" & vbCrLf & FileName, vbInformation, "タブ区切りテキストファイル作成完了" End If End Sub Private Function WriteTsvFile(TargetSheet As Worksheet) As String On Error GoTo WriteTabTxtFileErr Dim FileName As String Dim LastRow As Long Dim LastCol As Long Dim レコード As String Dim c As Variant Dim i As Long Dim FileNo As Integer ' アクティブシートをコピー ActiveSheet.Copy After:=Worksheets("最後のシート名") ' 1~2行目を削除 Range("1:2").Delete ' ファイル名を作成 FileName = Application.ThisWorkbook.Path & "\" & TargetSheet.Name & "_" & Format(Now, "yyyymmdd-hhmmss") & ".txt" FileNo = FreeFile() ' 最終行と最終列の取得 LastRow = Cells(Rows.Count, 1).End(xlUp).Row LastCol = Cells(1, Columns.Count).End(xlToLeft).Column i = 1 Open FileName For Output As #FileNo ' アラートOFF Application.DisplayAlerts = False Do Until i > LastRow For Each c In Cells(i, 1).Resize(, LastCol) レコード = レコード & vbTab & c.Value Next c Print #FileNo, Mid$(レコード, 2) レコード = "" i = i + 1 Loop Close #FileNo ' コピーしたシートを削除 ActiveSheet.Delete ' アラートON Application.DisplayAlerts = True WriteTsvFile = FileName Exit Function WriteTabTxtFileErr: MsgBox "[WriteTabTxtFile]" & vbCrLf & TargetSheet.Name & vbCrLf & Err.Description, vbCritical, "Exception" WriteTsvFile = "" Exit Function End Function ーーーーーーーここまでーーーーーーーーーーーー タイトル行およびサンプル行を削除してから処理を行っているため、 どこまでがデータが入るべき列なのか判断できずに空白列にタブが入らないのは当たり前なのですが、 これを回避する方法がまったくわからず困っております。 お知恵をお貸しください。

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

  • ベストアンサー
  • bin-chan
  • ベストアンサー率33% (1403/4213)
回答No.1

1行目•2行目をDeleteせずにおいて、i=3から始めたらどうでしょう。

guriguri3
質問者

お礼

大きな修正もなく、期待通りの動きになりました。 勉強になりました。 本当にありがとうございました。

関連するQ&A

  • エクセルに二つのテキストファイルをインポートしたい

    エクセルのsheet1の1行目にタイトルがあります。 ボタンのクリックイベントで、テキストファイル2つをインポートしたいのですが。 ・テキストファイルの名前は、固定ではありません ・テキストファイルの保存先は、デスクトップで、ファイルの選択は自分でしたい ・テキストファイルの一行目は、タイトル行なので、二行目以降をインポートしたい 行数は固定ではありません ・タブ区切りです 複数選択はできなく、1ファイルでタイトル行も含めるのであれば下記コードできたのですが。 どなたか、ご教示いただけますでしょうか・・・・ よろしくお願いいたします。 ----------------------------------------------------- Sub ReadTextFile() 'タブ区切りファイルを全て文字列として読み込む Dim FileName As String Dim i As Long Dim Cnt As Long Dim Buf As Variant Dim FileNo As Integer Dim SplitString As Variant 'ファイルダイアログを表示 FileName = Application.GetOpenFilename("テキストファイル,*.txt") If FileName <> "False" Then '全セル選択して書式を文字列にセットする Cells.Select Selection.NumberFormatLocal = "@" Cells(1, 6).Select '空いているファイル番号を取得 FileNo = FreeFile() Buf = Space(FileLen(FileName)) 'ファイルを開いてbufに1行読み込み ' → タブで配列に分割 ' → セルに書き出し Open FileName For Input As #FileNo Do Until EOF(FileNo) Line Input #FileNo, Buf Cnt = Cnt + 1 SplitString = Split(Buf, vbTab) For i = 0 To UBound(SplitString) Cells(Cnt, i + 1) = SplitString(i) Next i Loop Close #FileNo Else End If End Sub -----------------------------------------------------

  • vba エクセル

    2行目から、最終行までEmptyにしたいのにならないです。 1行目はフィールド行なのに、そのままにしたいのですが 2行目から最終行は空白にしたいです。 なので Sub TEST() With Sheets("log") lastRow = .Cells(.Rows.Count, "b").End(xlUp).Row LastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column .Range(.Cells(2, LastCol), .Cells(lastRow, LastCol)) = Empty End With End Sub としたのですが、何も起こりません。 lastRowは100、LastColは5なのですが、 このマクロを実行しても何も起こらないです。 なぜでしょうか?

  • VBAでタブ区切りテキストの保存に関して

    VBAでタブ区切りテキストの保存のプログラムを書くためには Application.DisplayAlerts = False Sheets("sheet01").Copy ActiveWorkbook.SaveAs Filename:="D:\test.txt", FileFormat:=xlText ActiveWindow.Close Application.DisplayAlerts = True という記述が一般的に使われます。 いま、あるプログラムでexcelシート上に title subtitle 001  002  003 333  444  555 666  777  888 ような内容が書き込まれたものをタブ区切りで出力したいのですが、 上記の方法で出力すると、 titleやsubtitleと書かれた行の右側にも空白のタブ区切りが一緒に保存されてしまいます。 あるプログラムで読み込ませるためには、 この二つの行のタブ区切りをいちいち消す必要があり、毎回手作業でするのは面倒です。 VBAでこのようなタブ区切りの有無を行ごとに指定して保存するようなことは可能でしょうか?

  • フォルダ内の複数ブックのデータとブック名を転記する

    フォルダの中に複数のExcelファイル(ブック)が入っており、 それら全てのブックデータの転記を一括して行うマクロを現在使用しています。(後述) <現在の利用状況> ・フォルダの中に複数のExcelファイル(ブック)が入っている。ファイルにつきシートは1つ(ひな形は同じ) ・ファイルを確認するまでデータが何行入っているか分からない ・貼り付ける際はシートの上部は意図的に消している <改善希望> ・どのファイルから貼り付けたか分かるように、A列にファイル名を追記したい(どの行にも) ・できれば先頭の3文字のみ VBA勉強中の初心者ですが、なるべく早く実装しないといけないので、困っています。。。。 ご教示頂けます様お願いいたします。 ========================= Sub データ集計() '集計シートを変数に格納 Dim ws As Worksheet Set ws = ActiveSheet '集計シートの最終行を取得 Dim LastRow As Long LastRow = ws.Cells(Rows.Count, 5).End(xlUp).Row MsgBox "このブックと同じフォルダにあるブックを全て統合します" 'このブックの保存されているフォルダのパス(番地;ディレクトリ)を変数に取得 Dim thisPath As String thisPath = ThisWorkbook.Path 'ディレクトリにあるExcelのファイル名を取得 Dim fileName As String fileName = Dir(thisPath & "\" & "*.xlsx") Dim i As Long 'ファイル名が無くなるまで繰り返す Do While fileName <> "" '開くワークブックを変数に代入 Dim bufBook As Workbook Set bufBook = Workbooks.Open(thisPath & "\" & fileName) '開いたブックの第1シートの全データ --> 集計シートの最終行 bufBook.Worksheets(1).Range("B14").CurrentRegion.Copy Destination:=ws.Range("B" & LastRow) '最初のループ以外では、タイトル行を削除しておく Dim LastRowSecond As Long LastRowSecond = LastRow + 13 If i > 0 Then ws.Rows(LastRow & ":" & LastRowSecond).Delete End If '開いたブックを閉じる bufBook.Close SaveChanges:=False '集計シートの最終行を再取得しておく LastRow = ws.Cells(Rows.Count, 7).End(xlUp).Row + 1 '次のファイル名が取り出される。 fileName = Dir() i = i + 1 Loop End Sub

  • エクセルVBAで困っています。

     エクセルでSheet1でSheet2に各銀行の出納帳を作りそこから各項目ごとに別Sheetに振り分けたいと思っています。  ある方にエクセルVBAで作って頂いたのですが、最初作って頂いた時の項目は会費、会議費、事務費の3つでした。その項目を9つに増やしたいと思っています。又、全てのSheetで1行目には銀行名や項目名を入れたいので2行目から日付、内容・・・といったように入力したいです。そうした場合、どこをどう変更したらよいのか分かりません。自分がわかる範囲で(適当ですが)挑んでみたのですが、私自体VBAについて全く無知のため何が何だかサッパリです。どなたか教えて頂くことはできないでしょうか。ちなみに文字数に制限があったため改行やスペースなどは入れていません。見難いとは思いますがよろしくお願いします。どうか皆様のお知恵を貸して頂けると幸いです。 Option Explicit Sub Teller() '【考え方】Sheet1とSheet2を入力と考える。 'マクロを実行したときに、Sheet1,2を元に、項目別に振り分ける。 Const BankName1 As String = "○銀行" Const BankName2 As String = "(チェック)銀行" Const tempSheet As String = "一時シート" Dim classify(9) As String Dim title(5) As String Dim i As Long Dim j As Long Dim lastRow1 As Long Dim lastRow2 As Long Dim findUpper As Long Dim findLower As Long Dim keyword As String Dim ws As Worksheet Dim Bank1 As Worksheet Dim Bank2 As Worksheet Dim Temp As Worksheet Set Bank1 = Worksheets(BankName1) Set Bank2 = Worksheets(BankName2) '【振り分ける項目名】 classify(1) = "会費" classify(2) = "会議費" classify(3) = "事務費" classify(4) = "事業費" classify(5) = "研修費" classify(6) = "報償費" classify(7) = "慶弔費" classify(8) = "予備費" classify(9) = "積立金" '【1行目に記載する見出し】 title(1) = "日付" title(2) = "内容" title(3) = "収入" title(4) = "支出" title(5) = "残高" '画面更新を停止 Application.ScreenUpdating = False '最終行取得 Bank1.Select lastRow1 = Cells(Rows.Count, 1).End(xlUp).Row Bank2.Select lastRow2 = Cells(Rows.Count, 1).End(xlUp).Row 'シートを作る For i = 1 To 3 Call MakeNewSheet_As_ThisName(classify(i)) For j = 1 To 5 Cells(1, j) = title(j) Next j Next i Call MakeNewSheet_As_ThisName(tempSheet) Cells.ClearContents Set Temp = Worksheets(tempSheet) '一時シートに、銀行1のデータと銀行2のデータをコピーする。 Bank1.Select Bank1.Range(Cells(3, 1), Cells(lastRow1, 5)).Copy Temp.Select Temp.Range(Cells(1, 1), Cells(lastRow1 - 2, 5)).PasteSpecial Bank2.Select Range(Cells(3, 1), Cells(lastRow2, 5)).Copy Temp.Select Cells(lastRow1 - 1, 1).PasteSpecial 'ソートする。 '第一優先キー:B列。[項目]昇順。 '第二優先キー:A列。[日付]昇順。 Range("A1:E" & (lastRow1 + lastRow2 - 4)).Select With ActiveWorkbook.Worksheets(tempSheet).Sort .SortFields.Clear .SortFields.Add Key:=Range("B1:B" & (lastRow1 + lastRow2 - 4)), Order:=xlAscending '第一キー .SortFields.Add Key:=Range("A1:A" & (lastRow1 + lastRow2 - 4)), Order:=xlAscending '第二キー .SetRange Range("A1:E" & (lastRow1 + lastRow2 - 4)) .Apply End With For i = 1 To 3 keyword = classify(i) findUpper = 0 findLower = 0 '上から探す For j = 1 To lastRow1 + lastRow2 - 4 Step 1 If Cells(j, 2) = keyword Then findUpper = j Exit For End If Next j If findUpper > 0 Then '下から探す For j = lastRow1 + lastRow2 - 4 To 1 Step -1 If Cells(j, 2) = keyword Then findLower = j Exit For End If Next j 'コピー Range(Cells(findUpper, 1), Cells(findLower, 5)).Copy Sheets(keyword).Select Range("A2").Select ActiveSheet.Paste Range("B2:B" & 2 + (findLower - findUpper)).Delete Shift:=xlToLeft Sheets(tempSheet).Select End If Next i '一時シートの削除 Application.DisplayAlerts = False Temp.Delete Application.DisplayAlerts = True 'アクティブセルをA1にしておく For Each ws In Worksheets Sheets(ws.Name).Select 'シート選択 Application.CutCopyMode = False Range("A1").Select Next ws Bank1.Select '画面更新を行う Application.ScreenUpdating = True MsgBox "実行しました" End Sub Sub MakeNewSheet_As_ThisName(ByVal GivenName As String) 'シートの有無を確認し、無ければ作る Dim exist_flag As Boolean Dim ws As Worksheet exist_flag = False For Each ws In Worksheets If UCase(ws.Name) = UCase(GivenName) Then 'シートが存在する場合 exist_flag = True Exit For End If Next ws 'シートを作成 If GivenName = "" Then MsgBox "空白名のシートは作れません。" ElseIf exist_flag = False Then Sheets.Add After:=Sheets(Sheets.Count) ActiveSheet.Name = GivenName End If Sheets(GivenName).Select 'シート選択 End Sub

  • テキストデータを出力するVBAがうまく動きません

    いつもお世話になっております。 複数あるシートのうち、シート名が数字になっているシートの一部をテキストファイルに出力するVBAを作成していますが、うまく動作しません。 (テキストファイルは作成できますが、データが書き込まれていません) シートをすべて検索しているのは、使用する人によってシート数がことなるためです。 おそらく繰り返し処理の部分で、何かおかしなことをやっているのだと思いますが、見ていただいて悪いところがありましたら、教えていただけますでしょうか。 Const Separater = "," ' 区切り文字をカンマに設定 '------------------------------------------------------------ Sub saveFile(fileName As String) '------------------------------------------------------------ Dim filePath As String Dim nowdate As String Dim startcd As Integer Dim endcd As Integer Dim St As Worksheet Dim Stn As String startcd = 0 endcd = 0 nowdate = Year(Date) & Month(Date) & Day(Date) filePath = fileName & nowdate & ".txt" '----filename は「savefile」を呼び出す際の引数 Dim dataRange As Range On Error Resume Next CreateObject("Scripting.FileSystemObject").createTextFile (filePath) '---- 全シート名のチェック For Each St In ThisWorkbook.Worksheets Stn = St.Name If IsNumeric(Stn) Then Worksheets(Stn).Activate Set dataRange = ActiveSheet.Range("A5:E71") '---- ファイルの書き込み処理 Dim RowStart%, RowEnd%, RowIndex% '--- 変数を整数型として宣言 RowStart = dataRange.Row RowEnd = dataRange.Row + dataRange.Rows.Count - 1 Dim ColStart%, ColEnd%, ColIndex ColStart = dataRange.Column ColEnd = ColStart + dataRange.Columns.Count - 1 Dim oneLine As String For RowIndex = RowStart To RowEnd '---- 1行の作成 oneLine = Stn & Separater & Cells(RowIndex, ColStart).Value For ColIndex = ColStart + 1 To ColEnd oneLine = oneLine & Separater & Cells(RowIndex, ColIndex).Value Next CreateObject("Scripting.FileSystemObject").writeLine oneLine '---- 1行の出力 Next End If Next St CreateObject("Scripting.FileSystemObject").Close '---- ファイルのクローズ End Sub

  • EXCEL VBA4行毎に枠で囲みたい

    お世話になります。 添付の様な表1があります。 これを表2のようにA1から順に4行毎に枠で囲みたいのです。 下記のようなコードを見よう見まねで書いてみましたがうまく動きません。 ごなたかご教授いただけませんでしょうか? よろしくお願い致します。 Dim i As Long Dim j As Long Dim lngYCnt As Long Dim intXCnt As Long Dim LastRow As Long ingYCnt = Worksheets("Sheet1").UsedRange.Rows.Count intXCnt = Worksheets("Sheet1").UsedRange.Columns.Count LastRow = Cells(Rows.Count, 1).End(xlUp).Row With Selection For i = 5 To LastRow Range("A" & i & ":F" & j).Select Selection.BorderAround Weight:=xlMedium j = j + 5 i = i + 5 Next End With どなたかご教授いただけませんでしょうか? よろしくお願い致します。 環境 EXCEL2003 WINDOWS XP SP3

  • エクセルのVBAでタブ区切りのテキスを出力したい。

    エクセルのVBAでテキスト出力をしたいのですが、 ・タブ区切りで保存 ・A列の最終行×1行目の最終列の範囲指定が対象 ・範囲内の空欄もタブ区切りにする(最終列には必ず数値あり) ・出力テキストはシートと同じフォルダ内へ格納 ・テキストファイル名はシート名 という感じにしたいのです。 いろいろ検索はしているのですが、これといった回答やサンプルは 見つかっておりません(><) ちなみに、私は、自動記録をしたものを改良して少し使えるレベルです。 よろしくお願いします。

  • エクセル 検索コピーマクロ

    マクロで検索、抽出して別ファイルに保存したいのですが、 以下のようなマクロを教えてもらったのですが コピー先のセル位置を任意の位置に直したいのですが、 どうしてもわかりません どの部分をどう直せばよいのでしょうか? Option Explicit Sub copyTodayData() Dim dateToday As String Dim tempDate As String Dim lastrow1 As Long Dim lastrow2 As Long Dim i As Long Dim fileA As String Dim anotherBook As String Dim anotherFilePath As String fileA = ThisWorkbook.Name anotherBook = "別のファイル.xls" anotherFilePath = "C:\Documents and Settings\日本太郎\デスクトップ\どこかのフォルダ" '問い合せダイアログの表示をOFFにします Application.DisplayAlerts = False 'ファイルを開く ChDir anotherFilePath Workbooks.Open Filename:=anotherFilePath & "\" & anotherBook '問い合せダイアログの表示をONに戻します Application.DisplayAlerts = True 'ウインドウの切替 Windows(fileA).Activate '今日の日付を取得 dateToday = Date 'データ最終行を取得 lastrow1 = Cells(Rows.Count, 1).End(xlUp).Row For i = 2 To lastrow1 If Cells(i, 1) = dateToday Then 'Range(Cells(i, 1), Cells(i, 4)).Copy 'コピー Windows(anotherBook).Activate 'ウインドウの切替 lastrow2 = Cells(Rows.Count, 1).End(xlUp).Row '別ブックの最終行 Cells(lastrow2 + 1, 1).Select ActiveSheet.Paste Windows(fileA).Activate 'ウインドウの切替 End If Next i MsgBox "実行しました" End Sub たぶん、lastrow2 = Cells(Rows.Count, 1).End(xlUp).Row '別ブックの最終行 Cells(lastrow2 + 1, 1).Select ここらへんというのは、わかりますが、 どこをどう変えたらいいかわかりません

  • VBAの動的配列について

    いつもお世話になっております。 エクセルVBAを学習中の者です。 動的配列についてお伺いします。 添付資料を見て頂きたいのですが、 シート名1~4に同一レイアウトの表があります。 これらの表をを2次元配列に格納し、その後、同一レイアウトのシートに一括転記したいと考えています。 転記の事を考えて、条件としては、 シート1から2行目以降のデータを配列『data』に格納、変数『dataCnt』が転記先の行番号と同じになるように考えています。 当初は、配列の定義を『Dim data(100,3) As Variant』と、多めに要素数を定義して、コードを記述していました。 正直、凄く気持ちが悪い感じでした・・・ 最近、動的配列を学習しまして、 シートごとにデータの行数を変数『lastRow』に格納して、配列を再定義して【データ数=要素数】とならないか? と思い、下記のようなコードを書いてみました。 が、『ReDim Preserve~』で実行エラーが発生してしまいます。 原因がなぜかわかりません! そもそも、動的配列はこのような使い方は出来ないのでしょうか? Sub テスト() Dim data() As Variant Dim x As Long Dim i As Long Dim ii As Long Dim lastRow As Long Dim dataCnt As Long dataCnt = 2 For x = 2 To 5 Worksheets(x).Activate lastRow = Cells(Rows.Count, 1).End(xlUp).Row If x = 2 Then ReDim data(2 To lastRow, 3) Else ReDim Preserve data(2 To dataCnt + lastRow - 1, 3) End If For i = 2 To lastRow For ii = 1 To 3 data(dataCnt, ii) = Cells(i, ii) Next ii dataCnt = dataCnt + 1 Next i Next x End Sub どなたかご指導をよろしくお願いいたします。

専門家に質問してみよう