エクセル

Question

に複数のテキストファイルのインポート2行目、私は2番目の行をインポートするマクロを記録している行2.

で始まるExcelにフォルダから複数のタブ区切りのテキストファイルの2行目インポートしたいです1行目のタブ区切りのテキストファイルを2行目からExcelに変換します（Excelのヘッダ行があります）。私はまた、複数のテキストファイルをExcelにインポートするコードを発見しました。私はそれらをまとめるのに困っている。私は記録されたマクロに複数のファイルインポート機能を追加したいと思います。

ここには、1つのテキストファイルの2番目の行をExcelの2番目の行にインポートするコードが記録されています。私はここで、複数のテキストファイルをインポートするためのコードがある

Sub Import() 
' 
' Import Macro 
' 

' 
With ActiveSheet.QueryTables.Add(Connection:= _ 
    "TEXT;C:\Users\t830439\Desktop\test\BTWP004217_2017_6_29_12'14'03'0001.upl", _ 
    Destination:=Range("$A$2")) 
    .CommandType = 0 
    .Name = "BTWP004217_2017_6_29_12'14'03'0001" 
    .FieldNames = True 
    .RowNumbers = False 
    .FillAdjacentFormulas = False 
    .PreserveFormatting = True 
    .RefreshOnFileOpen = False 
    .RefreshStyle = xlInsertDeleteCells 
    .SavePassword = False 
    .SaveData = True 
    .AdjustColumnWidth = True 
    .RefreshPeriod = 0 
    .TextFilePromptOnRefresh = False 
    .TextFilePlatform = 65001 
    .TextFileStartRow = 2 
    .TextFileParseType = xlDelimited 
    .TextFileTextQualifier = xlTextQualifierNone 
    .TextFileConsecutiveDelimiter = False 
    .TextFileTabDelimiter = True 
    .TextFileSemicolonDelimiter = False 
    .TextFileCommaDelimiter = False 
    .TextFileSpaceDelimiter = False 
    .TextFileColumnDataTypes = Array(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, _ 
    1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1 _ 
    , 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1) 
    .TextFileTrailingMinusNumbers = True 
    .Refresh BackgroundQuery:=False 
End With 
End Sub 

...その後3などを行、このコードは行2から始まるExcelに複数のテキストファイルの2行目インポートしたいです。上記の記録されたコードに追加された「すべてのファイルをループする」機能が必要です。私はすでにこのコードを実行するための正しい参照を追加しました。

Sub ReadFilesIntoActiveSheet() 
Dim fso As FileSystemObject 
Dim folder As folder 
Dim file As file 
Dim FileText As TextStream 
Dim TextLine As String 
Dim Items() As String 
Dim i As Long 
Dim cl As Range 

' Get a FileSystem object 
Set fso = New FileSystemObject 

' get the directory you want 
Set folder = fso.GetFolder("C:\Users\t830439\Desktop\test") 

' set the starting point to write the data to 
Set cl = ActiveSheet.Cells(2, 1) 

' Loop thru all files in the folder 
For Each file In folder.Files 
    ' Open the file 
    Set FileText = file.OpenAsTextStream(ForReading) 

    ' Read the file one line at a time 
    Do While Not FileText.AtEndOfStream 
     TextLine = FileText.ReadLine 

     ' Parse the line into | delimited pieces 
     Items = Split(TextLine, "|") 

     ' Put data on one row in active sheet 
     For i = 0 To UBound(Items) 
      cl.Offset(0, i).Value = Items(i) 
     Next 

     ' Move to next row 
     Set cl = cl.Offset(1, 0) 
    Loop 

    ' Clean up 
    FileText.Close 
Next file 

Set FileText = Nothing 
Set file = Nothing 
Set folder = Nothing 
Set fso = Nothing 

End Sub 

ありがとうございました。

EDIT - UPDATE ------------------------------------------- -

私はコードをマージしましたが、ループに渡すことはできません。

Sub ReadFilesIntoActiveSheet3() 
Dim fso As FileSystemObject 
Dim folder As folder 
Dim file As file 
Dim FileText As TextStream 
Dim TextLine As String 
Dim Items() As String 
Dim i As Long 
Dim cl As Range 

' Get a FileSystem object 
Set fso = New FileSystemObject 

' get the directory you want 
Set folder = fso.GetFolder("C:\Users\t830439\Desktop\test") 

' set the starting point to write the data to 
Set cl = ActiveSheet.Cells(2, 1) 

' Loop thru all files in the folder 
For Each file In folder.Files 
    ' Open the file 
    Set FileText = file.OpenAsTextStream(ForReading) 

    ' Read the file one line at a time 
    Do While Not FileText.AtEndOfStream 
     TextLine = FileText.ReadLine 

     ' Parse the line into | delimited pieces 
     'Items = Split(TextLine, "|") 

     ' Put data on one row in active sheet 
     ' For i = 0 To UBound(Items) 
     ' cl.Offset(0, i).Value = Items(i) 
     ' Next 

     'Move to next row 
     Set cl = cl.Offset(1, 0) 



    With ActiveSheet.QueryTables.Add(Connection:= _ 
    "TEXT;C:\Users\t830439\Desktop\test\BTWP004217_2017_6_29_12'14'03'0001.upl", _ 
    Destination:=Range("$A$2")) 
    ' .CommandType = 0 
    .Name = "BTWP004217_2017_6_29_12'14'03'0001" 
    .FieldNames = True 
    .RowNumbers = False 
    .FillAdjacentFormulas = False 
    .PreserveFormatting = True 
    .RefreshOnFileOpen = False 
    .RefreshStyle = xlInsertDeleteCells 
    .SavePassword = False 
    .SaveData = True 
    .AdjustColumnWidth = True 
    .RefreshPeriod = 0 
    .TextFilePromptOnRefresh = False 
    .TextFilePlatform = 65001 
    .TextFileStartRow = 2 
    .TextFileParseType = xlDelimited 
    .TextFileTextQualifier = xlTextQualifierNone 
    .TextFileConsecutiveDelimiter = False 
    .TextFileTabDelimiter = True 
    .TextFileSemicolonDelimiter = False 
    .TextFileCommaDelimiter = False 
    .TextFileSpaceDelimiter = False 
    .TextFileColumnDataTypes = Array(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, _ 
    1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1 _ 
    , 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1) 
    .TextFileTrailingMinusNumbers = True 
    .Refresh BackgroundQuery:=False 
End With 

    Loop 

    ' Clean up 
    FileText.Close 
Next file 

Set FileText = Nothing 
Set file = Nothing 
Set folder = Nothing 
Set fso = Nothing 

End Sub 

Answer 1

これはいかがですか？

Sub Basic_Example_1() 
    Dim MyPath As String, FilesInPath As String 
    Dim MyFiles() As String 
    Dim SourceRcount As Long, Fnum As Long 
    Dim mybook As Workbook, BaseWks As Worksheet 
    Dim sourceRange As Range, destrange As Range 
    Dim rnum As Long, CalcMode As Long 

    'Fill in the path\folder where the files are 
    MyPath = "C:\Users\Ron\test" 

    'Add a slash at the end if the user forget it 
    If Right(MyPath, 1) <> "\" Then 
     MyPath = MyPath & "\" 
    End If 

    'If there are no Excel files in the folder exit the sub 
    FilesInPath = Dir(MyPath & "*.xl*") 
    If FilesInPath = "" Then 
     MsgBox "No files found" 
     Exit Sub 
    End If 

    'Fill the array(myFiles)with the list of Excel files in the folder 
    Fnum = 0 
    Do While FilesInPath <> "" 
     Fnum = Fnum + 1 
     ReDim Preserve MyFiles(1 To Fnum) 
     MyFiles(Fnum) = FilesInPath 
     FilesInPath = Dir() 
    Loop 

    'Change ScreenUpdating, Calculation and EnableEvents 
    With Application 
     CalcMode = .Calculation 
     .Calculation = xlCalculationManual 
     .ScreenUpdating = False 
     .EnableEvents = False 
    End With 

    'Add a new workbook with one sheet 
    Set BaseWks = Workbooks.Add(xlWBATWorksheet).Worksheets(1) 
    rnum = 1 

    'Loop through all files in the array(myFiles) 
    If Fnum > 0 Then 
     For Fnum = LBound(MyFiles) To UBound(MyFiles) 
      Set mybook = Nothing 
      On Error Resume Next 
      Set mybook = Workbooks.Open(MyPath & MyFiles(Fnum)) 
      On Error GoTo 0 

      If Not mybook Is Nothing Then 

       On Error Resume Next 

       With mybook.Worksheets(1) 
        Set sourceRange = .Range("A2:AA2") 
       End With 

       If Err.Number > 0 Then 
        Err.Clear 
        Set sourceRange = Nothing 
       Else 
        'if SourceRange use all columns then skip this file 
        If sourceRange.Columns.Count >= BaseWks.Columns.Count Then 
         Set sourceRange = Nothing 
        End If 
       End If 
       On Error GoTo 0 

       If Not sourceRange Is Nothing Then 

        SourceRcount = sourceRange.Rows.Count 

        If rnum + SourceRcount >= BaseWks.Rows.Count Then 
         MsgBox "Sorry there are not enough rows in the sheet" 
         BaseWks.Columns.AutoFit 
         mybook.Close savechanges:=False 
         GoTo ExitTheSub 
        Else 

         'Copy the file name in column A 
         With sourceRange 
          BaseWks.Cells(rnum, "A"). _ 
            Resize(.Rows.Count).Value = MyFiles(Fnum) 
         End With 

         'Set the destrange 
         Set destrange = BaseWks.Range("B" & rnum) 

         'we copy the values from the sourceRange to the destrange 
         With sourceRange 
          Set destrange = destrange. _ 
              Resize(.Rows.Count, .Columns.Count) 
         End With 
         destrange.Value = sourceRange.Value 

         rnum = rnum + SourceRcount 
        End If 
       End If 
       mybook.Close savechanges:=False 
      End If 

     Next Fnum 
     BaseWks.Columns.AutoFit 
    End If 

ExitTheSub: 
    'Restore ScreenUpdating, Calculation and EnableEvents 
    With Application 
     .ScreenUpdating = True 
     .EnableEvents = True 
     .Calculation = CalcMode 
    End With 
End Sub 

https://www.rondebruin.nl/win/s3/win008.htm