痔になりやすい生活習慣とは?

VBA初心者です。宜しくお願いします。
複数のテキストファイルを一括でエクセルの同一Bookにシート毎に取り込みたいと考えております。ネットを色々調べてみて取り込みまでは出来たのですが、テキスト内容は空白によって区切られているので、セルごとに区切られません。エクセルにて1ファイルごとは取り込めるのですが、一括の場合は一つのセルにテキストがまとまってしまします。行は分かれてますが列が分かれません。色々と試しましたが、知識が無いためにこれ以上進みません。どうかお力を貸して下さい。win Excel2016です。

下記のソース?で取り込む事が出来ました。
Sub ReadTextFiles()
  Const DirName = "C:\Users\"
  '上記で指定されたフォルダに存在するファイルで、
  '拡張子がtxtのものをすべて1シートとして読み込む
  Dim fs As Object
Dim dir As Object
  Set fs = CreateObject("Scripting.FileSystemObject")
  Set dir = fs.GetFolder(DirName)
  Set fc = dir.Files
  For Each f1 In fc
    If LCase(fs.GetExtensionName(f1.Name)) = "txt" Then
      Worksheets.Add after:=Worksheets(Worksheets.Count)
      Sheets(Worksheets.Count).Name = f1.Name
      Set stream = f1.OpenAsTextStream
      Do While stream.AtEndOfStream <> True
        Cells(stream.Line, 1) = stream.ReadLine
      Loop
      stream.Close
    End If
  Next
End Sub

また下記がエクセルマクロにて保存した内容です。
With ActiveSheet.QueryTables.Add(Connection:= _
"TEXT;C:\Users\.txt", Destination:=Range( _
"$A$1"))

.CommandType = 0
.Name = "1001"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
.TextFilePlatform = 932
.TextFileStartRow = 1
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = False
.TextFileTabDelimiter = True
.TextFileSemicolonDelimiter = False
.TextFileCommaDelimiter = False
.TextFileSpaceDelimiter = False
.TextFileColumnDataTypes = Array(1, 1, 1, 1, 1, 1)
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
End With
End Sub

このQ&Aに関連する最新のQ&A

A 回答 (3件)

このように変更したらどうなりますか



myArray = Split(stream.ReadLine, Space(1))

myArray = Split(stream.ReadLine, vbTab)
    • good
    • 4
この回答へのお礼

ki-aaaさん有難う御座います。求めている結果になりました。

お礼日時:2017/01/07 13:34

いかのようにしてください。


-------------------------------------
Sub ReadTextFiles()
Const DirName = "C:\Users\"
'上記で指定されたフォルダに存在するファイルで、
'拡張子がtxtのものをすべて1シートとして読み込む
Dim fs As Object
Dim dir As Object
Dim RE As Object
Dim fc As Object
Dim f1 As Object
Dim stream As Object
Dim line As String
Dim items As Variant
Dim i As Long
Dim row As Long
Set RE = CreateObject("VBScript.RegExp")
RE.Pattern = "[ ]+"
RE.Global = True
Set fs = CreateObject("Scripting.FileSystemObject")
Set dir = fs.GetFolder(DirName)
Set fc = dir.Files
For Each f1 In fc
If LCase(fs.GetExtensionName(f1.Name)) = "txt" Then
Worksheets.Add after:=Worksheets(Worksheets.Count)
Sheets(Worksheets.Count).Name = f1.Name
Set stream = f1.OpenAsTextStream
Do While stream.AtEndOfStream <> True
row = stream.line
'連続する空白を1つにまとめる
line = stream.ReadLine
line = RE.Replace(line, " ")
items = Split(line, " ")
For i = 0 To UBound(items)
Cells(row, 1 + i).Value = items(i)
Next
Loop
stream.Close
End If
Next
End Sub
---------------------------
    • good
    • 1
この回答へのお礼

tatsu99さん有難う御座います。動作はしますが結果としては最初の状態と同じでした。

お礼日時:2017/01/07 13:35

これでどうかな



Sub ReadTextFiles()
Const DirName = "C:\Users\"
'上記で指定されたフォルダに存在するファイルで、
'拡張子がtxtのものをすべて1シートとして読み込む
Dim fs As Object
Dim dir As Object
Dim fc, f1, stream, myArray

Set fs = CreateObject("Scripting.FileSystemObject")
Set dir = fs.GetFolder(DirName)
Set fc = dir.Files

For Each f1 In fc
If LCase(fs.GetExtensionName(f1.Name)) = "txt" Then
Worksheets.Add after:=Worksheets(Worksheets.Count)
Sheets(Worksheets.Count).Name = f1.Name
Set stream = f1.OpenAsTextStream

Do While stream.AtEndOfStream <> True
myArray = Split(stream.ReadLine, Space(1))
If UBound(myArray) >= 0 Then
Cells(stream.Line, 1).Resize(1, UBound(myArray) + 1).Value = myArray
End If
Loop

stream.Close
End If
Next
End Sub
    • good
    • 0
この回答へのお礼

ki-aaaさん有難う御座います。私の説明がいけないんだと思いますが、取り込みはしましたけど私が記述した結果と同じでした。たぶんテキストデータの説明が悪いんだと思います。

動作結果このような形です。
文字列が分割されず、一つ目のセルに記述された状態です。

1111111あいうえお22222かきくけこ333333さしすせそ
2222222たちつてと55555さしすせそ7777779999999999

Cells(stream.Line, 1).Resize(1, UBound(myArray) + 6).Value = myArray とした場合に、
一つのセル毎に分割されない文字列がインポートされました。

参考になるか解りませんが、メモ帳に記述されているテキスト例はこのような感じです。

1111111  あいうえお 22222 かきくけこ 333333 さしすせそ
2222222  たちつてと 55555 さしすせそ 777777 9999999999
  
1ファイルをエクセルにてインポートする場合は、区切り文字で区切られています。
データプレビューにてみると、一つ目のセルと二つ目のセルの区切りを2列目の文字頭で
区切りがあり、以降の列も文字頭で区切られております。  

1111111  |あいうえお |22222 |かきくけこ |333333 |さしすせそ
2222222  |たちつてと |55555 |さしすせそ |777777 |9999999999

上手く伝えられなくて申し訳ありません。

お礼日時:2017/01/06 20:41

お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!

このQ&Aを見た人はこんなQ&Aも見ています

このQ&Aと関連する良く見られている質問

Q複数のテキストファイルをひとつのエクセルシートにまとめるには?

複数のテキストファイル(.txt)をエクセルのひとつのシートにまとめるにはどうすればいいですか?
またその際、個々のテキストファイルのファイル名を本文の前に挿入したいのですが、
そのやり方も教えていただけると助かります。
ただ、フリーソフトを使わずエクセルの機能だけでやりたいのでよろしくお願いします。
↓のような感じにしたいです。

-------------------------------------------
test1.txt
data data data data data data data data
data data data data data
data data data data data data

test2.txt
data2 data2 data2 data2 data2 data2 data2
data2 data2 data2 data2 data2 data2 data2
data2 data2 data2 data2 data2 data2

-------------------------------------------
Sheet1

現在、一つ一つのテキストファイルの名前をF2で選択してセルに貼り付け、
テキストファイルを開いて本文を前文コピーして貼り付け、というやり方でやってますが、
非常に時間がかかって困っています。
よろしくお願いします。

複数のテキストファイル(.txt)をエクセルのひとつのシートにまとめるにはどうすればいいですか?
またその際、個々のテキストファイルのファイル名を本文の前に挿入したいのですが、
そのやり方も教えていただけると助かります。
ただ、フリーソフトを使わずエクセルの機能だけでやりたいのでよろしくお願いします。
↓のような感じにしたいです。

-------------------------------------------
test1.txt
data data data data data data data data
data data data data data
data data data data d...続きを読む

Aベストアンサー

こんにちは。

#2のWendy02です。返事を待たずに、VBA用のコードを、WSH(Windows Script Host)を意識して、作ってみました。ただし、WSHに換えるためには、細かい点は直さなくてはなりません。

Sub TextFileConbining()
'テキストファイルをファイル名を出力てつなげる
Dim BaseFileName As String
Dim FileName As Variant
Dim fn As Variant
Dim FileNo As Integer
Dim objFSO As Object
Dim objFile As Object
Dim objText As Object
Dim TextLines As String

 Set objFSO = CreateObject("Scripting.FileSystemObject")
 BaseFileName = Application.InputBox("ベース・テキストファイル名をつけてください。" & vbCrLf & "拡張子(.txt)は不要です。", Type:=2)
  If VarType(BaseFileName) = vbBoolean Or BaseFileName = "" Then Exit Sub
 FileName = Application.GetOpenFilename("テキストファイル(*.txt),*.txt", , , , True)
  If VarType(FileName) = vbBoolean Then Exit Sub
 Set objFile = objFSO.OpenTextfile(ThisWorkbook.Path & "\" & BaseFileName & ".txt", 8, True)
 
 For Each fn In FileName
  If fn Like ThisWorkbook.Path & "\" & BaseFileName & ".txt" Then
   MsgBox fn & "は、ベース・テキストファイル名と同じです。" & Chr(13) & "スキップします。", vbInformation
  Else
  objFile.WriteLine (Mid$(fn, InStrRev(fn, "\") + 1) & Chr(13) & Chr(10))
  Set objText = objFSO.OpenTextfile(fn)
  TextLines = objText.ReadAll
  objText.Close
  objFile.Write TextLines
  End If
 Next
 objFile.Close
 Beep '終了の合図
 Set objFile = Nothing: Set objFSO = Nothing
End Sub

こんにちは。

#2のWendy02です。返事を待たずに、VBA用のコードを、WSH(Windows Script Host)を意識して、作ってみました。ただし、WSHに換えるためには、細かい点は直さなくてはなりません。

Sub TextFileConbining()
'テキストファイルをファイル名を出力てつなげる
Dim BaseFileName As String
Dim FileName As Variant
Dim fn As Variant
Dim FileNo As Integer
Dim objFSO As Object
Dim objFile As Object
Dim objText As Object
Dim TextLines As String

 Set objFSO = CreateObject("S...続きを読む

Q複数テキストファイルをエクセルで開く

度々の質問申し訳ございません。

複数のテキストファイルが入ったフォルダ内のすべてのテキストデータをエクセルの1シートで開きたいです。

他の方の同じような質問の御回答に以下のようなマクロが有りました。
Sub macro1()
Dim myPath As String
Dim myFile As String
Dim n, c, s

'初期化
myPath = ThisWorkbook.Path & "\"
myFile = Dir(myPath & "*.txt")

'受入準備
On Error Resume Next
Worksheets.Add before:=Worksheets(1)
ActiveSheet.Name = Format(Date, "yyyymmdd")
On Error GoTo 0

'ファイルの巡回
Do Until myFile = ""
n = n + 1
Cells(n, "A") = myFile

'データの読み出し
Open myPath & myFile For Input As #1
c = 1
Do Until EOF(1)
Line Input #1, s
c = c + 1
Cells(n, c) = s
Loop
Close #1

myFile = Dir()
Loop
End Sub

これを利用させていただいて、テキストファイルを開いたのですが、こちらのマクロですとテキストデータの1列目しか開く事が出来ません。(図参照)
1列目2列目共に開くには何処を変更すれば良いですか?
マクロはまったく理解できないので、何卒宜しくお願い致します。

また、できればエクセルの横方向に開くのではなく、縦方向に開けるようにして頂けると非常にありがたいです。

何卒宜しくお願い致します。

度々の質問申し訳ございません。

複数のテキストファイルが入ったフォルダ内のすべてのテキストデータをエクセルの1シートで開きたいです。

他の方の同じような質問の御回答に以下のようなマクロが有りました。
Sub macro1()
Dim myPath As String
Dim myFile As String
Dim n, c, s

'初期化
myPath = ThisWorkbook.Path & "\"
myFile = Dir(myPath & "*.txt")

'受入準備
On Error Resume Next
Worksheets.Add before:=Worksheets(1)
ActiveSheet.Name = Format(Date, "yyyymmdd")
On Error...続きを読む

Aベストアンサー

>マクロはまったく理解できないので、何卒宜しくお願い致します。
なら、テキストファイルがいくつあるのかわかりませんが、先にひとつのファイルにしちゃうとか。
ただし、EXCELの扱える行数には制限があるので注意してください。
(だからお使いのOSやEXCELのバージョンは書いておくほうが良い)

1)お使いのOSが不明だけど、たぶんアクセサリの中にある「コマンドプロンプト」を開く。
2)黒地に白字の画面になるので、キー入力で右のカッコ内を打つ。 [cd /d ]
3)対象ファイルがあるフォルダのフォルダアイコンを2)へドラッグ&ドロップ。
4)[cd /d C:\xxxxx] みたいになるので、キーボードの[Enter]を押下
5)キー入力で右のカッコ内を打つ。 [copy /b *.txt TextAll.tx] ←最後はtxです
6)「1個のファイルをコピーしました」と表示されるはず。
7)キー入力で右のカッコ内を打つ。 [ren TextAll.tx TextAll.txt] ←最後はtxtです
8)EXCELで対象ファイルがあるフォルダのファイル[TextAll.txt]を開く。

例示のVBAを修正するのであれば
Do Until EOF(1)
 Line Input #1, s
 c = c + 1
 Cells(n, c) = s
 Loop
Close #1

Do Until EOF(1)
 Line Input #1, s
 n = n + 1
 Cells(n, c) = s
 Loop
Close #1
にしてください。

>マクロはまったく理解できないので、何卒宜しくお願い致します。
なら、テキストファイルがいくつあるのかわかりませんが、先にひとつのファイルにしちゃうとか。
ただし、EXCELの扱える行数には制限があるので注意してください。
(だからお使いのOSやEXCELのバージョンは書いておくほうが良い)

1)お使いのOSが不明だけど、たぶんアクセサリの中にある「コマンドプロンプト」を開く。
2)黒地に白字の画面になるので、キー入力で右のカッコ内を打つ。 [cd /d ]
3)対象ファイルがあるフォルダのフ...続きを読む

QTXTファイルデーターをEXCELで読み込む

Aというテキストファイルがあります。
そのファイルのは、
1 12 123 1234
という様なスペースで分けられた文字列が並んでいます。
これを、新規作成したEXCELファイルで読み込みたいのですが、出来ますでしょうか?
現状は、テキストファイルをスペース区切りでEXCELに変換しているのですが、ファイル量が多くなりそうで手間がかかります。
ですので、テキストファイルから直接読み取りEXCELに貼り付けたいのです。(自動リンクのイメージでリンク元がAというテキストファイル)

以上、ご教示お願い致します。

Aベストアンサー

#8 です。

データの様子や動作仕様で不明な点はありますが、とりあえず現状の VBA
コードをアップしてみます。

リンクってのがよく分かりませんが、テキストのインポートでやりました。

下記のコードを実行すると、次の動作を行います。

1. このコードが書かれた同一フォルダ内の D*.txt をDOSコマンドで連結
  し、ファイル MergeData.txt に出力します。
2. MergeData.txt のデータを行単位でメモリ上に読み込みます。
3. 2.をアクティブシートのセルに展開します。
4. 最後にスペース区切りで各要素をセルに分割します。

なお、動作確認は WindowsXPsp2 + Excel2002sp3 の環境です。

30個程度のファイルなら、ループで回しても良かったのですが、何となく、、

ちなみに、テキストファイル毎に1枚のシートであれば、これはボツですね。

Option Explicit

Declare Function SetCurrentDirectory Lib "kernel32" _
  Alias "SetCurrentDirectoryA" _
  (ByVal lpPathName As String) As Long

Sub InportTextFile_Sample()
  
  Const ForReading& = 1, ForWriting& = 2, ForAppending& = 8
  Const BufSize& = 2000 '2000行
  
  Dim objShell As Object
  Dim FS    As Object, TS As Object
  Dim Buf()  As String
  Dim i    As Long
  Dim strPath As String
  
  'カレントディレクトリー設定
  strPath = ThisWorkbook.Path
  SetCurrentDirectory strPath
  
  'テキストファイルマージ
  Set objShell = CreateObject("WScript.Shell")
    objShell.Run "%ComSpec% /c COPY /b D*.txt MergeData.txt", 0, True
  Set objShell = Nothing
  
  'データバッファ
  ReDim Buf(BufSize)
  strPath = strPath & "\MergeData.txt"
  Set FS = CreateObject("Scripting.FileSystemObject")
  Set TS = FS.OpenTextFile(strPath, ForReading)
    Do Until TS.AtEndOfStream
      Buf(i) = Trim$(CStr(TS.ReadLine))
      i = i + 1
      If i > 65536 Then Exit Do
      If Not i Mod BufSize Then
        ReDim Preserve Buf(i + BufSize)
      End If
    Loop
    ReDim Preserve Buf(i)
    TS.Close
  Set TS = Nothing: Set FS = Nothing
  
  'セルに書き込み
  Application.ScreenUpdating = False
  ActiveSheet.Range("A1") _
    .Resize(UBound(Buf) + 1).Value = Application.Transpose(Buf)
  
  'バッファクリア
  Erase Buf
  
  'ソートするならここに書く
  
  '要素分割(SP区切り)
  ActiveSheet.Columns("A:A").TextToColumns _
    DataType:=xlDelimited, _
    TextQualifier:=xlDoubleQuote, _
    ConsecutiveDelimiter:=True, _
    Space:=True

  Application.ScreenUpdating = True
  MsgBox "終了しました.", vbInformation

End Sub

#8 です。

データの様子や動作仕様で不明な点はありますが、とりあえず現状の VBA
コードをアップしてみます。

リンクってのがよく分かりませんが、テキストのインポートでやりました。

下記のコードを実行すると、次の動作を行います。

1. このコードが書かれた同一フォルダ内の D*.txt をDOSコマンドで連結
  し、ファイル MergeData.txt に出力します。
2. MergeData.txt のデータを行単位でメモリ上に読み込みます。
3. 2.をアクティブシートのセルに展開します。
4. 最後にスペース...続きを読む

Q大量のCSVデータを1つのエクセルデータにまとめる方法について

今仕事で、CSVファイルが400ファイル程あり、これを一つの
エクセルファイルにまとめなくて加工しなければならないのですが
うまいことVBAを活用して効率的にできないか思案中なのですが
うまい具合に行きません。
データの持ち方として
○CSVファイル1
1.AAA
2.BBB

○CSVファイル2
3.CCC
4.DDD

となっており、これを1つのエクセルファイル上で
1.AAA
2.BBB
3.CCC
4.DDD
としたいのですがなにかいい方法はないでしょうか?
1つのブックで外部データの取り込みでCSVを次々に選択して
いくVBAなんてあれば教えていただけないでしょうか?
よろしくお願いします。

Aベストアンサー

こんにちは。
昔書いた事があるサンプルです。
同一フォルダにあるcsvファイルをまとめて処理します。

Sub CSVまとめsample()
  Dim MyObj As Object
  Dim MyFol As String
  Dim MyFnm As String
  Dim MyStr As String
  Dim i   As Long
  Dim n   As Long
  Dim n1  As Long
  
  'フォルダを選択する
  Set MyObj = CreateObject("Shell.Application") _
    .BrowseForFolder(0, "SelectFolder", 0)
  '選択なければ処理を抜ける
  If MyObj Is Nothing Then Exit Sub
  MyFol = MyObj.self.Path & "\"
  MsgBox MyFol & "を処理します。"
  Set MyObj = Nothing
  Application.ScreenUpdating = False
  'ThisWorkbookにシートを追加して処理
  With Sheets.Add
    'Dir関数を使って指定フォルダ内csvファイルを順次処理
    MyFnm = Dir(MyFol & "*.csv")
    Do Until Len(MyFnm) = 0&
      i = i + 1
      'データエリアを取得してセット先を変更
      n = IIf(n = 0, 1, n + n1)
      '外部データ取り込みを利用
      With .QueryTables.Add(Connection:="TEXT;" & MyFol & MyFnm, _
                 Destination:=.Range("B" & n))
        .AdjustColumnWidth = False
        .TextFilePlatform = xlWindows
        .TextFileStartRow = 1
        .TextFileCommaDelimiter = True
        .Refresh False
        n1 = .ResultRange.Rows.Count
        .Parent.Names(.Name).Delete
        .Delete
      End With
      'ファイル名をA列にセット
      .Range("A" & n).Resize(n1).Value = MyFnm
      '次のファイルへ
      MyFnm = Dir()
    Loop
  End With
  If i > 0 Then
    MyStr = i & "個のファイルを処理しました。"
  Else
    '検索結果が0なら
    MyStr = "検索条件を満たすファイルはありません。"
  End If
  Application.ScreenUpdating = True
  MsgBox MyStr
End Sub

#シート行数をオーバーした時のエラー処理などはしてないので
#うまくいかなかったらごめんね^ ^;

こんにちは。
昔書いた事があるサンプルです。
同一フォルダにあるcsvファイルをまとめて処理します。

Sub CSVまとめsample()
  Dim MyObj As Object
  Dim MyFol As String
  Dim MyFnm As String
  Dim MyStr As String
  Dim i   As Long
  Dim n   As Long
  Dim n1  As Long
  
  'フォルダを選択する
  Set MyObj = CreateObject("Shell.Application") _
    .BrowseForFolder(0, "SelectFolder", 0)
  '選択なければ処理を抜ける
  If MyObj Is Nothi...続きを読む

Qフォルダ内全ファイルをシート毎に貼付方法について

VBA仙人様ご教授お願い致します。

1フォルダに数十のログファイル(.txt)が格納されています。
1ファイルは3~5万行記述あります。
これを1つのExcelファイルにしたいと思っています。

VBA流れとして
(1)ログ格納フォルダを選択
(2)ログファイル名を取得
(3)既存Excelファイルに(2)で取得したファイル名(.txt除いた)で順次シートを追加
(4)ログファイル=シートとなるようにファイル読み込み/貼り付け
(5)ログファイルを閉じる

VBAイメージ
格納フォルダ:C:\test
\test内    :A001.txt,A002.txt,B003.txt・・・・・・・・Z051.txt(このフォルダにはログのみ格納)
C:デスクトップ\集計マクロ.excel (VBAの記述のあるExcelシートにはSheet1のみが存在)

VBA前
集計マクロ.excel/Sheet1
VBA実行後
集計マクロ.excel/Sheet1,A001,A002,B003,D004・・・・・・・・・Z051が追加、シート毎にログ情報記載

単一ファイルの読み込み/ファイル名をシート名に付与/情報コピペ/ファイル閉じについては、
作成できたのですが、複数ファイルの場合のファイル名を順次取得し、シート名として付与するなど
objやValiant変数などで試行錯誤しましたが解決できず、こちらに質問されていただきました><
このVBAで作成されたシートからの集計マクロについては完成していますが、
その手前でつまづいています><
ご教授のほどお願い致します><

VBA仙人様ご教授お願い致します。

1フォルダに数十のログファイル(.txt)が格納されています。
1ファイルは3~5万行記述あります。
これを1つのExcelファイルにしたいと思っています。

VBA流れとして
(1)ログ格納フォルダを選択
(2)ログファイル名を取得
(3)既存Excelファイルに(2)で取得したファイル名(.txt除いた)で順次シートを追加
(4)ログファイル=シートとなるようにファイル読み込み/貼り付け
(5)ログファイルを閉じる

VBAイメージ
格納フォルダ:C:\test
\test内    :A001.txt,A002.txt,B00...続きを読む

Aベストアンサー

#3です。
Set destRange = sh.Range("A1").Resize(UBound(buf) + 1, 1)
が正しいです。試験したファイルは最後にもCrLfが入っていたため、見落としてしまい申し訳ありません。
改行コードCrLfが一個も入っていないファイルの場合、UBound(buf)が0となるため、ご指摘のエラーになります。

また、行の区切りがCrLfでない場合は、
Const delimiter As String = vbCrLf
の所を、vbLfなのか、その他の任意の文字か分かりませんが、それに変更する必要があります。

行の区切りと、セルの区切りがある場合は、下記の様にできると思います。ただし、すべての行の要素数が同じとします。
buf = Split(textFile.ReadAll, delimiter)
buf2 = Split(buf(0), cellDelimiter)
Set destRange = sh.Range("A1").Resize(UBound(buf) + 1, UBound(buf2) + 1)
For i = 0 To UBound(buf)
destRange.Rows(i + 1) = Split(buf(i), cellDelimiter)
Next i

#3です。
Set destRange = sh.Range("A1").Resize(UBound(buf) + 1, 1)
が正しいです。試験したファイルは最後にもCrLfが入っていたため、見落としてしまい申し訳ありません。
改行コードCrLfが一個も入っていないファイルの場合、UBound(buf)が0となるため、ご指摘のエラーになります。

また、行の区切りがCrLfでない場合は、
Const delimiter As String = vbCrLf
の所を、vbLfなのか、その他の任意の文字か分かりませんが、それに変更する必要があります。

行の区切りと、セルの区切りがある場合は、下記の様...続きを読む

Q複数のcsvファイルを1つのEXCELファイルにマージするVBAを教えてください

csvファイル数は700~1000個程度でひとつのフォルダに格納されています。
このファイルをEXCEL形式で開くと、1行目にフィールド名(A~Z列で固定)、2行目以降にデータが入っています。行数はファイルにより1~100行程度で変動します。

このファイルを1つのエクセルファイルの同一シートに結合(マージ)するVBAがほしいです。
ここで、(できればですが)EXCELにマージするにあたり、1行目のみフィールドの値、2行目以降にそれぞれのcsvの2行目以降データの値を入れていくようにしたいです。つまり、フィールド名の行が何行も出てくるのを避けたいです。

申し訳ございませんが、ご指導いただけたら幸いです。よろしくお願いします。

Aベストアンサー

しばらく前に書いた事があるコードです。
参考になるようだったら応用してみてください。

'---------------------------------------------------------------------
Private Sub try()
  Dim ws As Worksheet
  Dim fd As String
  Dim fn As String
  Dim ret As String
  Dim i  As Long
  Dim n  As Long
  Dim x  As Long
  Dim s  As Long
  
  fd = ThisWorkbook.Path & "\"
  'fd = FDSELECT 'フォルダ選択の場合

  If Len(fd) = 0& Then Exit Sub
  Application.ScreenUpdating = False
  'ActiveWorkbookにシートを追加して処理
  Set ws = Sheets.Add
  On Error GoTo errHndler
  fn = Dir(fd & "*.csv")

  x = 1
  s = 1
  Do Until Len(fn) = 0&
    i = i + 1
    'データCountにより次のセット先変更
    n = n + x
    '外部データ取り込み
    x = CSVQRY(ws, fd & fn, ws.Cells(n, 2), s)
    If x < 0 Then
      Err.Raise Number:=1000, Description:="CSV読み込みに失敗"
    ElseIf (n + x) >= Rows.Count Then
      '行数overしてもエラーかからないため取り込み直し
      ws.Rows(n).Resize(x).Delete
      Set ws = Sheets.Add
      n = 1
      x = CSVQRY(ws, fd & fn, ws.Cells(n, 2), 1&)
    End If
    'ファイル名をA列にセット
    ws.Cells(n, 1).Resize(x).Value = fn
    s = 2
    fn = Dir()
  Loop

  If i > 0 Then
    ret = i & "files.done"
  Else
    ret = "no file"
  End If

errHndler:
  If Err.Number <> 0 Then
    ret = Err.Number & vbTab & Err.Description
    Debug.Print ret
  End If
  Application.ScreenUpdating = True
  MsgBox ret
  Set ws = Nothing
End Sub
'---------------------------------------------------------------------
Private Function CSVQRY(ByRef ws As Worksheet, _
            ByRef fs As String, _
            ByRef rs As Range, _
            ByVal sr As Long) As Long
  Dim cnt As Long

  On Error GoTo errChk
  With ws.QueryTables.Add(Connection:="TEXT;" & fs, _
              Destination:=rs)
    .AdjustColumnWidth = False
    .TextFilePlatform = xlWindows
    .TextFileStartRow = sr
    .TextFileCommaDelimiter = True
    .Refresh False
    cnt = .ResultRange.Rows.Count
    .Parent.Names(.Name).Delete
    .Delete
  End With
  CSVQRY = cnt
  Exit Function
errChk:
  CSVQRY = -1
End Function
'---------------------------------------------------------------------
Private Function FDSELECT() As String 'フォルダ選択Function
  Dim obj As Object
  Dim ret As String

  Set obj = CreateObject("Shell.Application") _
       .BrowseForFolder(0, "SelectFolder", 0)
  If obj Is Nothing Then Exit Function
  On Error Resume Next
  ret = obj.self.Path & "\"
  If Err.Number <> 0 Then
    ret = obj.Items.Item.Path & "\"
    Err.Clear
  End If
  On Error GoTo 0
  Set obj = Nothing
  FDSELECT = ret
End Function

しばらく前に書いた事があるコードです。
参考になるようだったら応用してみてください。

'---------------------------------------------------------------------
Private Sub try()
  Dim ws As Worksheet
  Dim fd As String
  Dim fn As String
  Dim ret As String
  Dim i  As Long
  Dim n  As Long
  Dim x  As Long
  Dim s  As Long
  
  fd = ThisWorkbook.Path & "\"
  'fd = FDSELECT 'フォルダ選択の場合

  If Len(fd) = 0& Then Exit Sub
 ...続きを読む

Qエクセルで、条件に一致した行を別のセルに抜き出す方法

エクセルで、指定した条件に一致するセルを含む行をすべて抜き出す方法が知りたいです。

たとえば、

<A列> <B列> <C列>
7/1 りんご 100円
7/2 ぶどう 200円
7/2 すいか 300円
7/3 みかん 100円

このような表があって、100円を含む行をそのままの形で、
別のセル(同じシート内)に抜き出したいのですが。

7/1 りんご 100円
7/3 みかん 100円

抽出するだけならオートフィルターでもできますが、
抽出結果を自動的に、別の場所に、常に表示させておきたいのです。

初歩的な質問だと思いますが、検索しても分からなかったので、よろしくお願いします。

Aベストアンサー

同じ質問が結構よく出てますが、そんなに初歩的でもありません
別シートのA1セルに「100円」と入力し、そのシートの任意のセルに以下の式を貼り付けて下さい。後は、下方向、右方向にコピー。
日付のセル書式は「日付」形式に再設定してください

=IF(COUNTIF(Sheet1!$C:$C,$A$1)>=ROW(A1),INDEX(Sheet1!A:A,LARGE(INDEX((Sheet1!$C$1:$C$500=$A$1)*ROW(Sheet1!$C$1:$C$500),),COUNTIF(Sheet1!$C:$C,$A$1)-ROW(A1)+1)),"")

データ範囲は500行までとしていますが、必要に応じて変更して下さい

QEXCELをTEXTに一括変換出来ませんか?

複数のEXCEL(複数のシートあり)を一括してテキスト化する手段又はツールはありませんか?若しくは一個のEXCELでもかまいません。量があるのでいちいち開いてTEXTセーブするのがつらくなってきました。

Aベストアンサー

私も、マクロやVBAは得意ではないので、あまり良いコードではないですが、とりあえずこれでできると思います。


エクセルを起動(Book1になってると思います)- Alt + F11 - Microsoft Visual Basic・・・ という画面が表示されたら
挿入 - 標準モジュール - 大きな白いスペースのところに下記のコードをコピペ。
Microsoft Visual Basic・・・を閉じてBook1にもどり念のため適当な場所に保存して下さい。

'------------この下からコピー--------------
Sub test()
Dim wb As Workbook
Dim st As Worksheet
Dim wbname As String
Dim stname As String

For Each wb In Workbooks
wb.Activate
If wb.Name <> ThisWorkbook.Name Then
wbname = Left$(wb.Name, Len(wb.Name) - 4)
For Each st In Worksheets
st.Activate
stname = st.Name
wb.SaveAs Filename:="C:\" & wbname & "_" & stname & ".txt", FileFormat:=xlText, CreateBackup:=False
Next
wb.Close savechanges:=False
End If
Next
End Sub
'------------この上まで-----------------------

そのあと、テキスト化したいエクセルをすべて開きます。
(先ほど作成したブックも開いた状態です)
メニューバーの ツール - マクロ -マクロ ー 表示されているマクロ(複数ある場合は、「TEST」が含まれているもの)
を選択し、実行ボタンをクリックします。
保存先は「C:\」(Cドライブ)です。

私も、マクロやVBAは得意ではないので、あまり良いコードではないですが、とりあえずこれでできると思います。


エクセルを起動(Book1になってると思います)- Alt + F11 - Microsoft Visual Basic・・・ という画面が表示されたら
挿入 - 標準モジュール - 大きな白いスペースのところに下記のコードをコピペ。
Microsoft Visual Basic・・・を閉じてBook1にもどり念のため適当な場所に保存して下さい。

'------------この下からコピー--------------
Sub test()
Dim wb As Workbook
...続きを読む

QEXCEL VBAマクロ作成で、他のEXCELからデータを取り込みたい

メインプログラム(EXCEL VBA)より、
他のフォルダーにあるEXCELの項目の内容を取り込みたいです。
たとえば他のフォルダーのEXCELのRange("A2:A3").ValueをメインプログラムのRange("C2:C3").Valueにセットしたい時です。

・コマンドボタン押したら、どこのEXCELから取り込むかのポップアップ(?)は、表示はできてます。
・作業者が選んだパスとブックもMsgBoxで表示できてるので、もらう相手の場所も取得できてます。

・となると次はOPEN,INPUTですか?
テキストデータの取り込みですと、Inputでそのバッファを定義してるのですが、なんか違うような。。。

よろしくお願いします!

Aベストアンサー

私がやる方法です。

Dim writeSheet As Worksheet ' 自分自身の書き出し先シート
Set writeSheet = ThisWorkbook.Worksheets(1) ' Sheet1 を参照

Dim readBook As Workbook ' 相手ブック
Set readBook = Workbooks.Open(filename) ' 相手ブックを開いて参照
Dim readSheet As WorkSheet ' 相手シート
Set readSheet = readBook.Worksheets("sheetName") ' 相手シートを参照
' または Set readSheet = readBook.Worksheets(sheetIndex)

' 例えば
writeSheet.Cells(1, 1).Value = readSheet.Cells(2, 2).Value ' 相手シートの B2 の値を自分自身の A1 に書き込む

readBook.Close False ' 相手ブックを閉じる
Set readSheet = Nothing
Set readBook = Nothing

私がやる方法です。

Dim writeSheet As Worksheet ' 自分自身の書き出し先シート
Set writeSheet = ThisWorkbook.Worksheets(1) ' Sheet1 を参照

Dim readBook As Workbook ' 相手ブック
Set readBook = Workbooks.Open(filename) ' 相手ブックを開いて参照
Dim readSheet As WorkSheet ' 相手シート
Set readSheet = readBook.Worksheets("sheetName") ' 相手シートを参照
' または Set readSheet = readBook.Worksheets(sheetIndex)

' 例えば
writeSheet.Cells(1, 1).Value = readSheet.Ce...続きを読む

Qエクセルで条件に一致したセルの隣のセルを取得したい

下のような「得点」という名前のシートがあります。
(「田中」のセルがA1です。)

 [ 田中 ][ 10 ][ 200 ]
 [ 山田 ][ 21 ][ 150 ]
 [ 佐藤 ][ 76 ][ 250 ]
 [ 鈴木 ][ 53 ][ 350 ]

別のシートのA1セルに、「佐藤」と入力すると、

 [ 佐藤 ]

「得点」シートから「佐藤」の列を見つけて、B1、C1に

 [ 佐藤 ][ 76 ][ 250 ]

のように表示させたいのですが、B1、C1にはどのような式を書けば良いのでしょうか。
「得点」シートでは氏名が重複する事はありません。
IF文を使うと思うのですが、いまいち良く分かりませんでした。

よろしくおねがい致します。

Aベストアンサー

こんにちは!
VLOOKUP関数で対応できます。
IF関数と併用すればエラー処理が可能です。

Excel2007以降のバージョンであれば
B1セルに
=IFERROR(VLOOKUP($A1,得点!$A:$C,COLUMN(B1),0),"")
としてC1セルまでオートフィルでコピー!
そのまま下へコピーすると行が2行目以降でも対応できます。

Excel2003までの場合は
=IF($A1="","",VLOOKUP($A1,得点!$A:$C,COLUMN(B1),0))

としてみてください、m(_ _)m


このQ&Aを見た人がよく見るQ&A

人気Q&Aランキング