説明が冗長になりそうですが・・・
たとえば「日別訪問動物」というフォルダがあるとします。
その中には、
20140206.txt
20140205.txt
20140204.txt ・・・
と、日別に名前がつけられたテキストファイルが複数入っています。
それぞれのテキストファイルは、以下のような内容が書き込まれています。
○20140206.txtの中身
今日わが家を訪問してきた動物は次の通りです。
3匹・・・イヌ、カエル
2匹・・・カワウソ
1匹・・・ライオン、ゾウ、オオカミ
○20140205.txtの中身
今日わが家を訪問してきた動物は次の通りです。
5匹・・・トラ
2匹・・・ネコ、イヌ
1匹・・・クマ
○20140204.txtの中身
今日わが家を訪問してきた動物は次の通りです。
3匹・・・ネコ、ライオン
1匹・・・カバ
このときに、”最新の日付で、ネコが訪れてきたときのネコの数”をエクセルVBAで抽出し、任意のセル(たとえばA1など)に貼りつけたいと考えています。
上記の例では、「2匹」を抽出したいと考えています(2月5日に訪れたネコ2匹)。
どのようにすればうまくいくでしょうか?
A 回答 (3件)
- 最新から表示
- 回答順に表示
No.3
- 回答日時:
私もやってみました
操作として、A列のどこかに「ネコ」と入力したら、
その横、B列に日付を、C列にx匹 を表示するものです。
フォルダの対象ファイル一覧を作った後、直近から Open 探す方法なので
ファイル数が多ければ、それなりに遅くなると思います。
ファイル内の解釈は、
1行づつ読み込みます
「・」が無い行はスキップ
「・」があれば、「・」区切りの最後を「、」区切りで
その区切ったものがA列に入力されたものだったら・・・・
という流れになっています。
(ベタな処理と思います)
Private Sub Worksheet_Change(ByVal Target As Range)
Dim sKey As String
Dim oFso As Object
Dim sS As String
Dim sBuf As String
Dim sAry() As String
Dim v As Variant
Const CPATH = "D:\Hoge\日別訪問動物\"
Const CCHKMOJI = "・"
Const CSEPMOJI = "、"
Const adVarChar = 200
Const adUseClient = 3
Const adOpenStatic = 3
Const adLockOptimistic = 3
With Target
If ((.Count <> 1) Or (.Column <> 1)) Then Exit Sub
sKey = .Value
If (Len(sKey) = 0) Then Exit Sub
Application.EnableEvents = False
.Offset(, 1) = ""
.Offset(, 2) = ""
Application.EnableEvents = True
End With
Set oFso = CreateObject("Scripting.FileSystemObject")
With CreateObject("ADODB.Recordset")
.Fields.Append "F1", adVarChar, 255
.CursorLocation = adUseClient
.CursorType = adOpenStatic
.LockType = adLockOptimistic
.Open
For Each v In oFso.GetFolder(CPATH).Files
If (oFso.GetExtensionName(v.Name) = "txt") Then
sS = oFso.GetBaseName(v.Name)
If ((Len(sS) = 8) And (Not sS Like "*[!0-9]*")) Then
.AddNew
.Fields(0) = v.Name
.Update
End If
End If
Next
If (.RecordCount > 0) Then
.Sort = "F1 DESC"
Do While (Not .EOF)
sS = .Fields(0)
With oFso.OpenTextFile(CPATH & sS)
Do While (Not .AtEndOfStream)
sBuf = .ReadLine
If ((InStr(sBuf, CCHKMOJI) > 0) _
And (InStr(sBuf, sKey) > 0)) Then
sAry = Split(Trim(sBuf), CCHKMOJI)
For Each v In Split(sAry(UBound(sAry)), CSEPMOJI)
If (v = sKey) Then
Application.EnableEvents = False
With Target
.Offset(, 1) = Format(oFso.GetBaseName(sS), "@@@@/@@/@@")
.Offset(, 2) = sAry(0)
End With
Application.EnableEvents = True
Exit For
End If
Next
If (Not IsEmpty(v)) Then Exit Do
End If
Loop
.Close
End With
If (Not IsEmpty(v)) Then Exit Do
.MoveNext
Loop
End If
.Close
End With
Set oFso = Nothing
End Sub
No.2
- 回答日時:
#1、cjです。
追加レスです。うっかり、安直過ぎました。
#1は、「"ネコ"を含む行の先頭文字列(数字)」を返すものなので、
"ネコ"に部分一致する"ヤマネコ"等にもヒットしてしまいますから、実用的でありませんでした。
完全一致版を(性質が大きく異なる)2種、挙げておきます。
"・"や"、"が区切り文字として(確実に)(全角で)使われていることが絶対条件になります。
「Sub testA()」「Sub testC()」を実行してテストしてみてください。
(◆の行の指定は確実に、、、)
///
' ' 次行以下、標準モジュール の先頭から 不足なく
Option Explicit
Private Const sFolPath As String = "D:\日別訪問動物\" ' ◆ フォルダパス&\ 正しく指定
Private Const sKeysA = "サル,イヌ,カエル,カワウソ,ライオン,ゾウ,オオカミ,トラ,ネコ,クマ,カバ" ' ← テスト用便宜上の定数
Private cn As Long ' ← テスト用便宜上の変数
Sub testA()
For cn = 0 To 10
Re8464141a
Next cn
End Sub
Sub Re8464141a()
Dim rtn ' 戻り値
Dim sKey As String ' 検索キーワード
Dim sFormatPtr As String ' 日付値を基に各テキストファイル名(フルパス)を整形するパターン
Dim sMatchPtr As String ' 検索キーワードを区切り文字で挟んで完全一致を図る検索パターン
Dim sFile As String ' 各テキストファイル名
Dim sTempLine As String ' 各テキストデータを行単位で読込む変数
Dim nlen As Long ' 検索キーワードの文字長
Dim nPos As Long ' 検索キーワードがヒットした桁位置
Dim i As Long ' ループ用(日付値相当)
Dim nFree As Integer ' テキスト読み込み用空きナンバー
sFormatPtr = """" & sFolPath & """yyyymmdd"".txt"""
sKey = Split(sKeysA, ",")(cn) ' ←テスト用便宜上の記述。 ◆ 検索キーワード、正しく指定
sMatchPtr = "*・*[・、]" & sKey & "、*"
nlen = Len(sKey)
nFree = FreeFile
For i = Date To Date - 365 Step -1
sFile = Format(i, sFormatPtr)
If Dir(sFile) <> "" Then
Open sFile For Input As #nFree
Do While Not EOF(nFree)
' ' テキストデータを一行ずつ変数に読み込む
Line Input #nFree, sTempLine
nPos = InStr(sTempLine, sKey)
If sTempLine & "、" Like sMatchPtr Then
rtn = Trim$(Split(sTempLine, "・")(0))
Close #nFree
Exit For
End If
Loop
Close #nFree
End If
Next i
Dim nR As Long
If IsEmpty(rtn) Then
MsgBox "notfound"
Else
' Debug.Print "■"; rtn; "■"; sKey; "■"; Format(i, "yyyymmdd")
With Sheets("Sheet1") ' ◆ シート名、正しく指定
nR = .Cells(Rows.Count, 1).End(xlUp).Row + 1
.Cells(nR, 1) = rtn ' A列 に "何匹?"
.Cells(nR, 2) = sKey ' B列 に "どの動物?"
.Cells(nR, 3) = Format(i, "yyyymmdd") ' C列 に "いつ?"
End With
End If
End Sub
Sub testC()
For cn = 0 To 10
Re8464141c
Next cn
End Sub
Sub Re8464141c()
Dim rtn ' 戻り値
Dim oFSO As Object ' As Scripting.FileSystemObject '
Dim oRegExp As Object ' As VBScript_RegExp_55.RegExp '
Dim sKey As String ' 検索キーワード
Dim sFormatPtr As String ' 日付値を基に各テキストファイル名(フルパス)を整形するパターン
Dim sFile As String ' 各テキストファイル名
Dim sBuf As String ' 各テキストデータを流し込む変数
Dim i As Long ' ループ用(日付値相当)
Dim flgHit As Boolean ' 各テキストファイルでマッチするかどうかフラグ
sFormatPtr = """" & sFolPath & """yyyymmdd"".txt"""
sKey = Split(sKeysA, ",")(cn) ' ←テスト用の記述。 ◆ 検索キーワード、正しく指定
' ' RegExp(正規表現)
Set oRegExp = CreateObject("VBScript.RegExp") ' New VBScript_RegExp_55.RegExp
With oRegExp
.Global = True
.Pattern = "(^|[\r\n])[\s\t ]*([^\s\t ・]+)・[^\n]+[・、]" & sKey & "([\r\n、]|$)"
End With
' ' FSO(ファイルシステムオブジェクト)
Set oFSO = CreateObject("Scripting.FileSystemObject") ' New Scripting.FileSystemObject
For i = Date To Date - 365 Step -1
sFile = Format(i, sFormatPtr)
If oFSO.FileExists(sFile) Then
With oFSO.GetFile(sFile).OpenAsTextStream
sBuf = .ReadAll
.Close
End With
flgHit = oRegExp.test(sBuf)
If flgHit Then Exit For
End If
Next i
Dim nR As Long
If flgHit Then
rtn = oRegExp.Execute(sBuf)(0).SubMatches(1)
' Debug.Print "■"; rtn; "■"; sKey; "■"; Format(i, "yyyymmdd")
With Sheets("Sheet1") ' ◆ シート名、正しく指定
nR = .Cells(Rows.Count, 1).End(xlUp).Row + 1
.Cells(nR, 1) = rtn ' A列 に "何匹?"
.Cells(nR, 2) = sKey ' B列 に "どの動物?"
.Cells(nR, 3) = Format(i, "yyyymmdd") ' C列 に "いつ?"
End With
Else
MsgBox "notfound:" & sKey
End If
Set oFSO = Nothing: Set oRegExp = Nothing
End Sub
No.1
- 回答日時:
こんにちは。
比較的ベーシックなやり方で、、、。
(◆の行は運用に合わせて正しく指定。さもないとエラー。)
(△の行は必要に合わせる為のオプション。)
Sub Re8464141()
Const sFolPath As String = "D:\日別訪問動物\" ' ◆ フォルダパス&\ 正しく指定
Dim rtn ' 戻り値
Dim arrS() As String ' テキストを行ごとに区切って配列として格納
Dim sKey As String ' 検索キーワード
Dim sCurDir As String ' 現在のフォルダパスを確保
Dim sFile As String ' 各テキストファイルのファイル名
Dim sBuf As String ' 各テキストファイルのテキスト全文
Dim i As Long ' ループ用
Dim nFree As Integer ' テキスト読み込み用空きナンバー
' sKey = "サル"
' sKey = "カエル"
sKey = "ネコ"
' sKey = "クマ"
' sKey = "カバ"
sCurDir = CurDir()
ChDir sFolPath
nFree = FreeFile
For i = Date To Date - 365 Step -1
sFile = Format(i, "yyyymmdd"".txt""")
If Dir(sFile) <> "" Then
Open sFile For Input As #nFree
sBuf = StrConv(InputB(LOF(nFree), #nFree), vbUnicode)
Close #nFree
arrS() = Split(sBuf, vbCrLf) ' ◆ 改行文字、正しく指定
arrS() = Filter(arrS(), sKey, True)
' arrS() = Filter(arrS(), sKey, True, vbTextCompare) ' ←△ op.全角カナの徹底が怪しい場合
If UBound(arrS()) <> -1 Then
rtn = Split(Trim$(arrS(0)), "・")(0)
' rtn = Val(Trim$(arrS(0))) & "匹" ' ←△ op.区切り文字"・"の徹底が怪しい場合
Exit For
End If
End If
Next i
If IsEmpty(rtn) Then
MsgBox "notfound"
Else
With Sheets("Sheet1") ' ◆ シート名、正しく指定
.Cells(1, 1) = rtn ' A1 に "何匹?"
' .Cells(1, 2) = sKey ' △ B1 に "どの動物?"
' .Cells(1, 3) = sFile ' △ C1 に "いつ?"
End With
End If
ChDir sCurDir
End Sub
お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!
似たような質問が見つかりました
- Excel(エクセル) 【VBA】指定フォルダに格納中のテキストファイルをエクセルで処理し結果のエクセルを新規フォルダに保存 1 2022/03/25 14:19
- その他(プログラミング・Web制作) Pythonの質問です テキストファイルをこのように自動生成したいのですがどうすれば良いでしょうか. 2 2022/08/25 21:28
- Visual Basic(VBA) エクセルのマクロについて教えてください。 2 2023/07/16 14:36
- Visual Basic(VBA) エクセルのマクロについて教えてください。 1 2023/08/08 11:02
- Visual Basic(VBA) エクセルのマクロについて教えてください。 4 2023/07/15 16:33
- Excel(エクセル) Excelにて、フォルダ内のTextファイルをマクロで統合すると文字化けしてしまう時の解消コード 4 2023/01/01 07:32
- Visual Basic(VBA) VBAでエクセルをtxtに変換するとエクセルでカンマを含む文字数字がtxtでは「""」付にならないよ 1 2022/08/27 12:17
- Visual Basic(VBA) エクセルのマクロについて教えてください。 4 2023/02/05 09:55
- Visual Basic(VBA) エクセルのマクロについて教えてください。 2 2023/07/15 15:48
- Visual Basic(VBA) ExcelのVBAコードについて教えてください。 1 2023/08/08 15:45
このQ&Aを見た人はこんなQ&Aも見ています
-
新NISA制度は今までと何が変わる?非課税枠の拡大や投資対象の変更などを解説!
少額から投資を行う人のための非課税制度であるNISAが、2024年に改正される。おすすめの銘柄や投資額の目安について教えてもらった。
-
テキストファイルから特定の文字列が入った行を取得したいです。 例えば下記のような文が記載されたテキス
Visual Basic(VBA)
-
VBAでエクセルシートを更新(リフレッシュ)する方法を教えて下さい。
Excel(エクセル)
-
セルの値が変ると自動でマクロが実行される。
その他(Microsoft Office)
-
-
4
指定の動作中ユーザーフォーム終了方法
Excel(エクセル)
-
5
VBAでブックを非表示で開いて処理して閉じる方法
Excel(エクセル)
-
6
VBA Evaluate関数 型が一致しません
Excel(エクセル)
-
7
VBA データ(特定値)のある最終行を取得したい
Excel(エクセル)
-
8
マクロを使ってフォルダー内にあるtxtデータをエクセルにデータに変換する方法をご教授願います
Excel(エクセル)
関連するカテゴリからQ&Aを探す
おすすめ情報
このQ&Aを見た人がよく見るQ&A
デイリーランキングこのカテゴリの人気デイリーQ&Aランキング
-
VBAでパワーシェルを実行したい...
-
【VB.NET】App.configにファイ...
-
初心者powershellのPS1ファイル...
-
SaveAsの保存先について
-
エクセルvbaでdocuworksprinter...
-
【VBA】ExcelマクロでCSVファイ...
-
C#でのProcess.Startと変数path
-
xcopyコマンドの進行状況を表示...
-
パスワード保護されたExcelファ...
-
FolderBrowserDialogについて-2
-
EXCEL(VBA)で指定フォルダ内の...
-
バッチファイル 二つ上のディ...
-
SendKeysステートメント
-
VBAで、VBのapp.pathと同じ機能...
-
エクセルVBAで一つ上の階層...
-
AccessからExcel最小化
-
エディットボックスの数値をテ...
-
開いているファイルを削除し、...
-
DOSのバッチファイルでカレント...
-
Excel 相対パス
マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング
-
バッチファイル 二つ上のディ...
-
エクセルvbaでdocuworksprinter...
-
エクセルVBAで一つ上の階層...
-
Excel 相対パス
-
【VB.NET】App.configにファイ...
-
xcopyコマンドの進行状況を表示...
-
【VBA】ExcelマクロでCSVファイ...
-
EXCEL(VBA)で指定フォルダ内の...
-
エクセルのマクロで特定フォル...
-
パスワード保護されたExcelファ...
-
ExcelVBAの使い方 ¥の使い方...
-
開いているファイルを削除し、...
-
SaveAsの保存先について
-
初心者powershellのPS1ファイル...
-
fopenでのパス指定
-
VBA★PDFをPDFアプリで印刷し...
-
【Excel VBA】Power Qurry のソ...
-
指定したフォルダ内の最新ファ...
-
A列に記載されているフォルダ...
-
ExcelのVBAで上書き保存を確...
おすすめ情報