- ベストアンサー
エクセルVBAで住所録からテキストファイルを作成
piroin654の回答
'ADOのレコードセットを使用 Sub testMain() Dim myCon As New ADODB.Connection Dim FileName As String Dim rs1 As New ADODB.Recordset Dim rs2 As New ADODB.Recordset Dim rs3 As New ADODB.Recordset Dim conStr As String Dim strSQL1 As String Dim strSQL2 As String Dim strSQL3 As String Dim dic1 As Object Dim dic2 As Object Dim buf1 As Variant Dim buf2 As Variant Dim i As Long Dim j As Long Dim fso As Object Dim strPath As String Set dic1 = CreateObject("Scripting.Dictionary") Set dic2 = CreateObject("Scripting.Dictionary") strSQL1 = "SELECT 大分類 FROM [Sheet1$] GROUP BY 大分類" strSQL2 = "SELECT * FROM [Sheet1$]" strSQL3 = "SELECT * FROM [Sheet1$]" 'カレントフォルダのパス strPath = ThisWorkbook.Path '接続先のExcelファイル(質問の場合は現在のファイル) FileName = ThisWorkbook.FullName conStr = "Provider=Microsoft.Jet.OLEDB.4.0;" & _ "Extended Properties=Excel 8.0;" & _ "Data Source=" & FileName '接続 myCon.Open conStr 'レコードセットを開く rs1.Open strSQL1, myCon, adOpenStatic, adLockReadOnly rs2.Open strSQL2, myCon, adOpenStatic, adLockReadOnly rs3.Open strSQL2, myCon, adOpenStatic, adLockReadOnly If rs1.RecordCount > 0 Then rs1.MoveFirst Do Until rs1.EOF If Not IsNull(rs1!大分類) Then 'フォルダ作成 Call cmdMkDir(rs1!大分類) '中分類の取得 If rs2.RecordCount > 0 Then rs2.MoveFirst Do Until rs2.EOF '大分類と同じ分類の中分類を検索 If rs2!大分類 = rs1!大分類 Then If Not IsNull(rs2!中分類) Then buf1 = rs2!中分類 If Not dic1.exists(buf1) Then '検索済みの中分類をDictionaryに格納 dic1.Add buf1, buf1 '中分類ファイルの作成 Call cmdMakeChuFile(strPath & "\" & rs1!大分類, buf1) '小分類の取得 rs3.MoveFirst Do Until rs3.EOF '大分類および中分類が同じ小分離の検索 If rs2!大分類 = rs3!大分類 And buf1 = rs3!中分類 Then If Not IsNull(rs3!小分類) Then buf2 = rs3!小分類 If Not dic2.exists(buf2) Then '検索済みの小分類をDictionaryに格納 dic2.Add buf2, buf2 '小分類ファイルの作成 Call cmdMakeShoFile(strPath & "\" & rs1!大分類, buf2) End If End If End If '変数とDictionaryの初期化 buf2 = "" dic2.RemoveAll '次のレコードに移動 rs3.MoveNext Loop End If End If End If '次のレコードに移動 rs2.MoveNext Loop End If '変数とDictionaryの初期化 buf1 = "" dic1.RemoveAll End If '次のレコードに移動 rs1.MoveNext Loop End If '後始末 (オブジェクトの破棄が主) rs1.Close: Set rs1 = Nothing rs2.Close: Set rs2 = Nothing rs3.Close: Set rs3 = Nothing myCon.Close: Set myCon = Nothing Set dic1 = Nothing Set dic2 = Nothing End Sub Sub cmdMkDir(ByVal strDir As String) Dim obj As Object Dim strPath As String Dim strFolder As String Set obj = CreateObject("Scripting.FileSystemObject") strPath = ThisWorkbook.Path strFolder = obj.BuildPath(strPath, strDir) obj.CreateFolder strFolder Set obj = Nothing End Sub Sub cmdMakeChuFile(ByVal strPath As String, ByVal strFileName As String) Dim strFile As String strFile = strPath & "\" & strFileName & ".html" Open strFile For Output As #1 Print #1, "<html>" Print #1, "中分類ファイル" & "-------" & strPath & "-------" & strFileName Print #1, "</html>" Close #1 End Sub Sub cmdMakeShoFile(ByVal strPath As String, ByVal strFileName As String) Dim strFile As String strFile = strPath & "\" & strFileName & ".html" Open strFile For Output As #1 Print #1, "<html>" Print #1, "小分類ファイル" & "-------" & strPath & "-------" & strFileName Print #1, "</html>" Close #1 End Sub
関連するQ&A
- エクセルVBAでリストを仕分けしてファイル出力
会社リストからHTMLファイルを作成しています。 1つの地域で1つのファイルにしています。 地域によっては会社数が多くなってきたので、 20社ごとにファイルを別にして出力したいと考えております。 tokyo tokyo2 tokyo3 tokyo4 ・ ・ ・ G列のファイル名を20社ごとに変換するには 以下のソースをどのように改良すれば良いのか、ご教授願います。 Sub HTMLファイル出力() Dim myPath As String Dim i As Long myPath = Environ("USERPROFILE") & "\Desktop\Hoge\" Range("A:G").Sort Key1:=Range("G2"), Header:=xlYes, MatchCase:=False, _ Orientation:=xlTopToBottom For i = 2 To Range("G1").End(xlDown).Row If Range("G" & i).Text <> Range("G" & i - 1).Text Then Open myPath & Range("G" & i).Text & ".html" For Output As #1 Print #1, "<!DOCTYPE html>" & vbNewLine _ & "<html lang=""en"">" & vbNewLine _ & "<body>" & vbNewLine _ & "<div class=""span3"" id=""sidebar"">" & vbNewLine End If Print #1, "<div class=""widget"">" & vbNewLine _ & "<h4 class=""widgetTitle"">" & Range("A" & i).Text & "</h4>" & vbNewLine _ & "<ul><li>" & Range("B" & i).Text & "</li>" & vbNewLine _ & "<li>" & Range("C" & i).Text & "</li>" & vbNewLine _ & "<li>" & Range("D" & i).Text & "</li>" & vbNewLine _ & "<li>" & Range("E" & i).Text & "</li></ul></div>" & vbNewLine If Range("G" & i).Text <> Range("G" & i + 1).Text Then Print #1, "</div>" & vbNewLine & "</body>" & vbNewLine & "</html>" Close #1 End If Next End Sub
- ベストアンサー
- Visual Basic
- テキストファイルをエクセルに移すマクロのことで?
以前、複数のテキストファイルをエクセルに移すマクロを教えてもらったのですが、 以下マクロですと、フォルダのパスを指定しないといけません。 今回教えてもらいたいのは、フォルダのパスを指定しなくてもよい方法です。 どういう事かと言うと、仮にディスクトップにフォルダがあるとします。 そのフォルダの中には、マクロが入っているエクセルシートとテキストが入っているフォルダです。 つまり、そのフォルダ内だけで、処理をしたいと考えています。 また、フォルダ名は、その時によって異なります。 今までは、以下の方法を使っていたのですが、ちょっと使いにくいと感じています。 申し訳ありませんが、どなたか教えていただけないでしょうか? Sub Macro() Dim fso As Object Set fso = CreateObject("Scripting.FileSystemObject") Dim FolderPath As String 'ここのアドレスをファイルが格納されているフォルダのパスに変えてください FolderPath = "C:\Users\・・・" Dim myFile As Object Dim i As Long i = 2 Dim myFolder As Object For Each myFolder In fso.GetFolder(FolderPath).SubFolders For Each myFile In fso.GetFolder(myFolder).Files Cells(i, 4).Value = myFolder Cells(i, 1).Value = myFile.Name Cells(i, 7).Value = fso.OpenTextFile(myFile.Path).ReadAll() i = i + 1 Next Next End Sub Private Sub CommandButton1_Click() End Sub
- ベストアンサー
- オフィス系ソフト
- エクセルVBAでブックのデータをテキストファイルに
エクセル「Excel2003」ブックのデータを仕分けしてテキストファイルを作成する。 住所録(全国一覧表:シート1枚に記載)があります。 住所ごとにデータを分けて、個別のテキストファイルを作成する ※テキストファイルのファイル名は地域コード(英数字)にする。 tokyo.html ※テキストファイルの種類は、HTMLファイル ※住所録の項目は、 会社名、住所、電話、FAX、担当者、地域コード の6個 ※HTMLファイルに表示させるのは地域コードを除いた5項目 ※以下は、HTMLファイルの例になります。 <!DOCTYPE html> <html lang="en"> <body> <div class="span3" id="sidebar"> <div class="widget"> <h4 class="widgetTitle">会社名1</h4> <ul><li>住所1</li> <li>電話番号1</li> <li>ファックス1</li> <li>担当者1</li></ul></div> <div class="widget"> <h4 class="widgetTitle">会社名2</h4> <ul><li>住所2</li> <li>電話番号2</li> <li>ファックス2</li> <li>担当者2</li></ul></div> <div class="widget"> <h4 class="widgetTitle">会社名3</h4> <ul><li>住所3</li> <li>電話番号3</li> <li>ファックス3</li> <li>担当者3</li></ul></div> <div class="widget"> <h4 class="widgetTitle">会社名4</h4> <ul><li>住所4</li> <li>電話番号4</li> <li>ファックス4</li> <li>担当者4</li></ul></div> <div class="widget"> <h4 class="widgetTitle">会社名5</h4> <ul><li>住所5</li> <li>電話番号5</li> <li>ファックス5</li> <li>担当者5</li></ul></div> <div class="widget"> <h4 class="widgetTitle">会社名6</h4> <ul><li>住所6</li> <li>電話番号6</li> <li>ファックス6</li> <li>担当者6</li></ul></div> </div> </body> </html>
- ベストアンサー
- Visual Basic
- VBAでtextファイルを作成
マクロ・VBA初心者です。 ご教授お願いします!! 経費精算のExcelデータを画像のような「"",]で区切ったテキストファイルを作成するマクロを作りたいと考えてます。 完成イメージ:マクロのボタンを押すとテキストファイルの形でフォルダに作成される。もしくは、マクロボタンを押すとテキストファイルの形で区切ったものが表示されるものを作りたいです。 *経費精算データに関してA列からX列まであり、集計データにより列にデータを埋めていく作業が入っております。なので、A列からX1列まででデータが記入されている範囲で集計できるようにしたいと考えております。 現在は、勉強しつつ組み立てた結果、 CSVのExcelファイルをフォルダの中に作成できるようになりました。 (コードは下記に記載します) ただ、テキストファイルが作れるコードができていないのが問題です。 このコードをどのように変えればよいのか? もしくは、別のコードで出来るようならば教えていただけると嬉しく思います。 宜しくお願いします。 ______________________________ 〈コード〉 Option Explicit Sub ExcelファイルCSV形式作成() '変数宣言 Dim filePath As String Dim i As Long Dim maxRow As Long Dim fileNo As Integer '初期値設定 filePath = ActiveWorkbook.Path & "\経費計算エクセル(CSV保存).csv" maxRow = Range("A1").End(xlDown).Row '最終行取得 fileNo = FreeFile 'FreeFile関数で使用可能なファイル番号取得 'ファイル開く Open filePath For Output As #fileNo '最終行までループ For i = 1 To maxRow '列の数は決め打ち Write #fileNo, Cells(i, 1), Cells(i, 2), Cells(i, 3), Cells(i, 4), Cells(i, 5), Cells(i, 6); Cells(i, 7), Cells(i, 8), Cells(i, 9); Cells(i, 10), Cells(i, 11), Cells(i, 12); Cells(i, 13), Cells(i, 14), Cells(i, 15); Cells(i, 16), Cells(i, 17), Cells(i, 18); Cells(i, 19), Cells(i, 20), Cells(i, 21); Cells(i, 22), Cells(i, 23), Cells(i, 24) Next i 'ファイル閉じる Close #fileNo End Sub ______________________________________ 以上です。 本当に困ってます。よろしくお願します。
- ベストアンサー
- Visual Basic
- エクセルVBAでファイル作成
エクセルVBAで、データをフィルタで抽出し、別なBOOKの指定シートに転記し、名前をつけて保存したいのです。一応、下記のコードでテストは成功しました。 しかし下記コードでは1回ごとにデータの転記先を開かなくてはなりません。 処理する件数が多いので、できればいちいち新たに開き直さなくともよい方法はないでしょうか? 最初から開いておいて、転記後名前をつけて保存すると、開いていたファイルが閉じてしまい、うまくいきません。 別BOOKでなく別シートに転記して、そのシートをMoveして別ファイル保存ならわかるのですが、今回はどうしても別BOOKに転記しなければなりません。 よろしくお願いします。 Option Explicit Sub データ分割転記() Dim myPth As String, fname As String Dim myRng As Range, myC As Range Dim i As Long, x As Long Dim wb(2) As Workbook Dim ws As Worksheet Dim t As Single t = Timer Set wb(0) = ThisWorkbook myPth = wb(0).Path With wb(0).Sheets("Key") Set myRng = .Range("A2", .Range("A2").End(xlDown)) 'KeyData End With For Each myC In myRng Application.EnableEvents = False Set wb(1) = Workbooks.Open(Filename:=myPth & "\20150806TEST.xlsm") Set ws = wb(1).Sheets("List") With wb(0).Sheets("DATA") .Range("A1:J1").AutoFilter Field:=4, Criteria1:=myC.Value .Range("A2", .Range("A2").SpecialCells(xlLastCell)).SpecialCells(xlCellTypeVisible).Copy ws.Range("A9") .ShowAllData End With With ws x = .Cells(Rows.Count, "A").End(xlUp).Row myC.Offset(, 2).Value = x '行数確認 .Range("A9").Value = 1 If x > 9 Then .Range("A9").AutoFill Destination:=.Range("A9:A" & x), Type:=xlFillSeries '連番 End If End With wb(1).SaveAs Filename:=myPth & "\作成ファイル\" & myC.Value & ".xlsm" wb(1).Close (False) Application.EnableEvents = True i = i + 1 Next MsgBox i & "件を完了" _ & vbCrLf & Timer - t & " Sec." End Sub *Application.EnableEvents = False を使っているのば別BOOKが持つイベントマクロを作動させないためです。
- ベストアンサー
- Excel(エクセル)
- エクセルからテキストファイルはきだし
エクセルのひとつのシートの内容をテキスト形式で吐き出すマクロを教えてください。 エクセルでHTMLメルマガの商品名や金額を編集できるようにしたいのですが、その編集後のファイルをテキストで出すマクロのVBAの書き方を教えてください。 現在、以下で書いておりますがエクセルの中にある「$」が消えてしまいます。$が消えないような書き方を教えてください。また、""が余分についてしまう書き方は避けたいです。よろしくお願い致します。 Sub test() Dim StrFN As String StrFN = ActiveWorkbook.Path & "\data.txt" Dim i As Long, LngLoop As Long Dim IntFlNo As Integer Worksheets("HTML").Activate LngLoop = Range("a65536").End(xlUp).Row IntFlNo = FreeFile Open StrFN For Output As #IntFlNo For i = 1 To LngLoop Print #IntFlNo, Cells(i, 1) Next i Close #IntFlNo End Sub
- ベストアンサー
- Visual Basic
- エクセル、マクロの事で・・・?(2)
昨日、質問した者です。 http://okwave.jp/qa/q7374907.html 以下のマクロを教えてもらいました。 昨日の質問では、エクセルのA列にフォルダ名、B列にファイル名、それぞれフォルダとtxtを出力するマクロを教えてもらいました。 そこでもう一つ質問があるのですが、C列の内容をテキストに出力する場合はどうすればいいのでしょうか? 度々の質問で申し訳ありませんが、教えていただけないでしょうか? よろしくお願いします。 sub macro1() dim myPath as string dim h as range on error resume next mypath = thisworkbook.path worksheets(1).select for each h in range("A1:A" & range("A65536").end(xlup).row) mkdir mypath & "\" & h.value open mypath & "\" & h.value & "\" & h.offset(0, 1).value & ".txt" for output as #1 close #1 next end sub
- ベストアンサー
- オフィス系ソフト
- VBでテキストファイルを作成して,また消したい
VisualBasicでDLLファイルを呼び出して実行したいのですが, その際に,テキストに一度引数を入れたいと思っています. しかし,不要になれば,そのつどプログラムの中でテキストファイルを削除したいと思っています. テキスト作成は Open App.Path + "\新規作成.txt" For Output Access Write As 1 mystring = "ByVal ImaFile As String" Print #1, mystring Close #1 でできたのですが, テキストを削除する方法を教えてください. HELPには Sub Manip_Files() Dim fso As New FileSystemObject, txtfile As TextStream, fil1 As File, fil2 As File Set txtfile = fso.CreateTextFile("c:\testfile.txt", True) MsgBox "ファイルを削除します。" ' 現在の位置でファイルのハンドルを取得します。 Set fil1 = fso.GetFile("c:\tmp\testfile.txt") Set fil2 = fso.GetFile("c:\temp\testfile.txt") ' ファイルを削除します。 fil1.Delete fil2.Delete MsgBox "完了しました。" End Sub という方法が載っているのですが, 最初のFileSystemObjectでひっかかります. 参照設定が足らないと思われるのですが, 何を加えたらいいのでしょうか. 教えてください.
- ベストアンサー
- Visual Basic
- vba ファイルの移動について
フォルダAの中にあるたくさんのpdfファイルの中から、 ファイル名の頭文字3つがE列に記載した「aaa」だったら フォルダBに移動させるという内容にしたいです。 ネット検索などで、近いものを作成しましたが(下に貼り付け)、 下から4行目、「fso.moveFile FolderA & "\" & fileName, FolderB & "\" & fileName」で 「実行時エラー'53' ファイルが見つかりません。」 とエラーが出てしまいます。 どの様に書き直せばよいのでしょうか? どなたかご存じでしたら、ぜひお教え下さい。 よろしくお願いします。 エクセル2010を使用しています。 Sub CheckAndMoveFiles() Dim FolderA As String Dim FolderB As String FolderA = Range("D1").Value FolderB = Range("B2").Value Dim fso As Object Set fso = CreateObject("Scripting.FileSystemObject") Dim ws As Worksheet Set ws = ActiveSheet Dim lastRow As Long lastRow = ws.Range("E" & Rows.Count).End(xlUp).Row Dim r As Long Dim fileName As String For r = 1 To lastRow If ws.Cells(r, "E").Value <> "" Then fileName = ws.Cells(r, "E").Value dFileName = Dir(FolderA & "\" & Left(fileName, 3) & "*.pdf") Do While dFileName <> "" dFileName = Dir() Loop fso.moveFile FolderA & "\" & fileName, FolderB & "\" & fileName 'ここでストップ End If Next End Sub
- ベストアンサー
- Excel(エクセル)
- VBAでCSVファイルを読み込もうとしていますが、
VBAでCSVファイルを読み込もうとしていますが、 「ファイルが見つかりません」とエラーが表示されます。 どのように対処していいのかわかりません。 教えてくください。 Sub readCsv() Dim csvFile As String Dim ch As Integer Dim csvStr As String Dim str() As String Dim i As Integer Set ShellApp = CreateObject("Shell.Application") Set oFolder = ShellApp.BrowseForFolder(0, "フォルダ選択", 1) targetFolder = oFolder.Items.Item.Path Set fso = CreateObject("Scripting.FileSystemObject") Set fileList = fso.GetFolder(targetFolder).Files For Each file In fileList csvFile = file.Name ch = FreeFile Open csvFile For Input As #ch i = 1 Do While Not EOF(1) Line Input #ch, csvStr Close #ch str = Split(csvStr, ",") Range(Cells(i, 1), Cells(i, UBound(str) + 1)) = str i = i + 1 Loop Next End Sub
- ベストアンサー
- Visual Basic