エクセルまたはアクセスの仕様でxlsへのTXTファイルのインポートを自動化

Question

私は約900のCSVファイルを持っています。これらのファイルはすべてトラッキングソフトウェアからエクスポートされています。残念なことに、このソフトウェアは約52行ほどの要約データを、ヘッダーが多いフレームデータによってフレームの上の行にインポートします。

は私が探しているされているような方法で：

1）

2）保存要約データファイル名 "Original_Summary"

3と別のスプレッドシートとしてCSVファイルを開きます。 ）元のファイル名をワークシートの新しい名前として別のExcelファイルにフレームデータ（ヘッダを含む）を保存します。

これまでは、〜124個のファイルを手動で作成していましたが、ファイルの数が不足しているため、手動で行うのが最良の選択肢ではありません。

これらのExcelファイルを別々のテーブルとしてAccessにインポートするスクリプトをもう1つ作成しましたが、今はCSVからそれらを転送する方法が必要です。別のファイル。

私はこれを行う方法がありますか？

ありがとうございます！

Sub ImportManyTXTs_test() 
Dim strFile As String 
Dim foldername As String 
Dim ws As Worksheet 
strFile = Dir("C:\Users\Jared\Desktop\Processed\Text\*.txt") 
Do While strFile <> vbNullString 
Set ws = Sheets.Add 
With ws.QueryTables.Add(Connection:= _ 
    "TEXT;" & "C:\Users\Jared\Desktop\Processed\Text\" & strFile, Destination:=Range("$A$1")) 
    .Name = strFile 
    '.FieldNames = True 
    '.RowNumbers = False 
    '.FillAdjacentFormulas = False 
    '.PreserveFormatting = True 
    '.RefreshOnFileOpen = False 
    '.RefreshStyle = xlInsertDeleteCells 
    '.SavePassword = False 
    '.SaveData = True 
    '.AdjustColumnWidth = True 
    '.RefreshPeriod = 0 
    '.TextFilePromptOnRefresh = False 
    '.TextFilePlatform = 437 
    '.TextFileStartRow = 52 
    '.TextFileParseType = xlFixedWidth 
    '.TextFileTextQualifier = xlTextQualifierDoubleQuote 
    '.TextFileConsecutiveDelimiter = False 
    '.TextFileTabDelimiter = False 
    '.TextFileSemicolonDelimiter = False 
    '.TextFileCommaDelimiter = False 
    '.TextFileSpaceDelimiter = False 
    '.TextFileColumnDataTypes = Array(xlYMDFormat, 1, 1) 
    '.TextFileFixedColumnWidths = Array(22, 13, 13) 
    '.TextFileTrailingMinusNumbers = True 
    '.Refresh BackgroundQuery:=False 
    '.CommandType = 0 
    '.Name = "T15_070916_B" 
    .FieldNames = True 
    .RowNumbers = False 
    .FillAdjacentFormulas = False 
    .PreserveFormatting = True 
    .RefreshOnFileOpen = False 
    .RefreshStyle = xlInsertDeleteCells 
    .SavePassword = False 
    .SaveData = True 
    .AdjustColumnWidth = True 
    .RefreshPeriod = 0 
    .TextFilePromptOnRefresh = False 
    .TextFilePlatform = 437 
    .TextFileStartRow = 52 
    .TextFileParseType = xlDelimited 
    .TextFileTextQualifier = xlTextQualifierDoubleQuote 
    .TextFileConsecutiveDelimiter = False 
    .TextFileTabDelimiter = True 
    .TextFileSemicolonDelimiter = False 
    .TextFileCommaDelimiter = False 
    .TextFileSpaceDelimiter = False 
    .TextFileColumnDataTypes = Array(1, 1) 
    .TextFileTrailingMinusNumbers = True 
    .Refresh BackgroundQuery:=False 

End With 
ActiveSheet.Name = strFile 
strFile = Dir 
Loop 
End Sub 

私はこれを試してみた、そして唯一の最初の99かそこら、私のすべてのファイルをアップロードしていないようです、それはまた、新しいワークブックに持つというだけで新しいワークシートをインポートしません元の拡張子。何らかの理由で、ファイルを削除してからやり直さなければならない前に1回だけ動作します。奇妙です

私はまだコーディングに新しいので、どんな助けもありがとう！

Answer 1

SQLとQueryTableソリューションを検討してください。 ACE Engine（Windowsの.dllファイル）を使用すると、csvファイルを照会できます。特に、先頭のサマリー行にはSELECT TOP 52 *を実行し、行53から始まる最下行にはQueryTableを使用します（ACE SQLにはBOTTOMという述語がありません）。以下は

は、ループ内でこれらのメソッドを呼び出す、ワークブックおよびワークシートのマクロcreatigで上部と下部の両方の機能を設定します：@Parfaitへ

Sub ExtractCSV() 
    Dim wb As Workbook 
    Dim strfile As String, strpath As String 

    strpath = "C:\Users\Jared\Desktop\Processed\Text\" 
    strfile = Dir("C:\Users\Jared\Desktop\Processed\Text\*.txt") 

    Do While strfile <> vbNullString 
     Set wb = Workbooks.Add() 

     wb.Sheets(1).Name = "Original Summary" 
     wb.Sheets.Add After:=wb.Sheets(wb.Worksheets.Count) 
     wb.Sheets(2).Name = "Frame" 

     Call TopSummary(wb, strpath, strfile) 
     Call BottomFrame(wb, strpath, strfile) 

     wb.SaveAs strpath & "\" & Replace(strfile, ".csv", ".xlsx"), xlWorkbookDefault 
     wb.Close True 

     strfile = Dir 
    Loop 

    Set wb = Nothing 
End Sub 

Function TopSummary(currwb As Workbook, strpath As String, strfile As String) 
    Dim conn As Object, rst As Object 
    Dim strConnection As String, strSQL As String 
    Dim i As Integer 

    Set conn = CreateObject("ADODB.Connection") 
    Set rst = CreateObject("ADODB.Recordset") 

    ' CONNECTION STRING 
    strConnection = "Provider=Microsoft.ACE.OLEDB.12.0;" _ 
         & "Data Source=" & strpath & ";" _ 
         & "Extended Properties=""text;HDR=Yes;FMT=Delimited;""" 

    ' OPEN DB CONNECTION 
    conn.Open strConnection  

    ' QUERY CSV 
    strSQL = " SELECT TOP 52 * FROM " & strfile 

    ' OPEN QUERY RECORDSET 
    rst.Open strSQL, conn 

    currwb.Sheets(1).Range("A2").CopyFromRecordset rst 
    currwb.Sheets(1).Range("A:A").TextToColumns DataType:=xlDelimited, _ 
               ConsecutiveDelimiter:=False, Tab:=True 

    rst.Close: conn.Close 
    Set rst = Nothing: Set conn = Nothing 

End Function 

Function BottomFrame(currwb As Workbook, strpath As String, strfile As String) 
    Dim qt As QueryTable 

    ' ADD QUERYTABLE 
    With currwb.Sheets(2).QueryTables.Add(Connection:="TEXT;" & strpath & "\" & strfile, _ 
     Destination:=currwb.Sheets(2).Cells(1, 1)) 
      .TextFileStartRow = 53 
      .TextFileParseType = xlDelimited 
      .TextFileConsecutiveDelimiter = False 
      .TextFileTabDelimiter = True 
      .TextFileSemicolonDelimiter = False 
      .TextFileCommaDelimiter = False 
      .TextFileSpaceDelimiter = False 

      .Refresh BackgroundQuery:=False 
    End With 

    ' REMOVE QUERYTABLE 
    For Each qt In currwb.Sheets(2).QueryTables 
     qt.Delete 
    Next qt 

    Set qt = Nothing 
End Function 

Answer 2

おかげで、私はいくつかのコードを開発することができましたそれは私がしたいと思ったことでした。

Sub ExtractCSV() 
    Dim wb As Workbook 
    Dim y As Workbook 



    Dim strfile As String, strpath As String 

'Adjust the line below to have the appropriate folder directory, changing from new folder to something 

    strpath = "C:\Users\me\Desktop\Processed\Text\" 
    strfile = Dir("C:\Users\me\Desktop\Processed\Text\*.txt") 

    Do While strfile <> vbNullString 

     Workbooks.OpenText Filename:=strpath & strfile, Origin:= _ 
     437, StartRow:=1, DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, _ 
     ConsecutiveDelimiter:=False, Tab:=True, Semicolon:=False, Comma:=False _ 
     , Space:=False, Other:=False, FieldInfo:=Array(Array(1, 1), Array(2, 1), _ 
     Array(3, 1), Array(4, 1), Array(5, 1), Array(6, 1), Array(7, 1), Array(8, 1), Array(9, 1), _ 
     Array(10, 1), Array(11, 1), Array(12, 1), Array(13, 1), Array(14, 1), Array(15, 1), Array(_ 
     16, 1), Array(17, 1), Array(18, 1), Array(19, 1), Array(20, 1), Array(21, 1), Array(22, 1), _ 
     Array(23, 1), Array(24, 1), Array(25, 1), Array(26, 1), Array(27, 1), Array(28, 1), Array(_ 
     29, 1), Array(30, 1), Array(31, 1), Array(32, 1), Array(33, 1), Array(34, 1), Array(35, 1), _ 
     Array(36, 1), Array(37, 1), Array(38, 1), Array(39, 1), Array(40, 1), Array(41, 1), Array(_ 
     42, 1), Array(43, 1), Array(44, 1), Array(45, 1), Array(46, 1), Array(47, 1), Array(48, 1), _ 
     Array(49, 1), Array(50, 1), Array(51, 1), Array(52, 1), Array(53, 1), Array(54, 1), Array(_ 
     55, 1), Array(56, 1), Array(57, 1), Array(58, 1), Array(59, 1), Array(60, 1), Array(61, 1), _ 
     Array(62, 1), Array(63, 1), Array(64, 1), Array(65, 1), Array(66, 1), Array(67, 1), Array(_ 
     68, 1), Array(69, 1), Array(70, 1), Array(71, 1), Array(72, 1), Array(73, 1), Array(74, 1), _ 
     Array(75, 1), Array(76, 1), Array(77, 1)), TrailingMinusNumbers:=True 

     Set y = ActiveWorkbook 

     'Adjust the line below to have the appropriate folder directory, changing from new folder to something 

     ActiveWorkbook.SaveAs Filename:= _ 
     "C:\Users\me\Desktop\New folder\todelete\" & strfile, FileFormat:= _ 
     xlOpenXMLWorkbook, CreateBackup:=False 

     Set wb = Workbooks.Add() 


     wb.Sheets(1).Name = Left(strfile, Len(strfile) - 4) 
     wb.Sheets.Add After:=wb.Sheets(wb.Worksheets.Count) 
     wb.Sheets(2).Name = Left(strfile, Len(strfile) - 4) & "_Original_Summary" 


     y.Sheets(Left(strfile, Len(strfile) - 4)).Rows("1:51").Copy 
     'y.Sheets(Left(strfile, Len(strfile) - 4)).Selection.Copy 
     wb.Sheets(Left(strfile, Len(strfile) - 4) & "_Original_Summary").Range("A1").PasteSpecial 
     y.Sheets(Left(strfile, Len(strfile) - 4)).Rows("52:1600").Copy 
     'y.Sheets(Left(strfile, Len(strfile) - 4)).Selection.Copy 
     wb.Sheets(Left(strfile, Len(strfile) - 4)).Range("A1").PasteSpecial 
     y.Application.CutCopyMode = False 
     y.Close True 

     'Call TopSummary(wb, strpath, strfile) 
     'Call BottomFrame(wb, strpath, strfile) 

     'wb.SaveAs strpath & "\" & Replace(strfile, ".txt", ".xlsx"), xlWorkbookDefault 
     wb.SaveAs Filename:="C:\Users\me\Desktop\New folder\" & Left(strfile, Len(strfile) - 4) & ".xlsx" 

     wb.Close True 

     strfile = Dir 
    Loop 

    Set wb = Nothing 
End Sub 

私が恐れている唯一のことは、多くのリソースを使用する可能性があることです。うまくいけばそれはしませんが、私がこれをテストした少数のファイルでは、うまくいきました！