テキストファイルをシートに変換した後、スペース（区切り文字）を保持しますか？

テキストファイルとあなたが私に望む結果をアップロードしていただけませんか？

こんにちは、DesとPB Rama Murty、以下のコードは、テキストファイルをシートにインポートするときに、スペースまたはタブに基づいてデータを列に分割できます。 試してみることができます。

Sub ImportTextToExcel（）
'UpdatebyExtendoffice20180911
ワークブックとしてxWbを暗くする
xToBookをワークブックとして薄暗くする
文字列としての薄暗いxStrPath
xFileDialog を FileDialog として薄暗くする
文字列としての薄暗いxFile
新しいコレクションとしての薄暗いxFiles
薄暗い私は長く
薄暗いxIntRowAsLong
薄暗いxFNum、xFArr As Long
Dim xStrValue を文字列として
範囲としての薄暗いxRg
薄暗いxArr
xFileDialog = Application.FileDialog（msoFileDialogFolderPicker）を設定します
xFileDialog.AllowMultiSelect = False
xFileDialog.Title="フォルダを選択[KutoolsforExcel]"
xFileDialog.Show=-1の場合
xStrPath = xFileDialog.SelectedItems（1）
終了する場合
xStrPath = ""の場合、Subを終了します
If Right（xStrPath、1）<> "\" Then xStrPath = xStrPath＆ "\"
xFile = Dir（xStrPath＆ "* .txt"）
xFile=""の場合
MsgBox「ファイルが見つかりません」、vbInformation、「KutoolsforExcel」
サブを終了
終了する場合
xFile <> ""
xFiles.Add xFile、xFile
xFile = Dir（）
ループ
xToBook=ThisWorkbookを設定します
エラーで次の再開
Application.ScreenUpdating = False
xFiles.Count>0の場合Then

I=1の場合xFiles.Countへ
xWb = Workbooks.Open（xStrPath＆xFiles.Item（I））を設定します
xWb.Worksheets（1）.Copy after：= xToBook.Sheets（xToBook.Sheets.Count）

ActiveSheet.Name = xWb.Name

xWb.Close False
xIntRow = ActiveCell.CurrentRegion.Rows.Count
xFNum=1の場合xIntRow
xRg = ActiveSheet.Range（ "A"＆xFNum）を設定します
xArr = Split（xRg.Text、 ""）
UBound（xArr）>0の場合
xFArr = 0の場合UBound（xArr）へ
If xArr（xFArr）<> "" Then
xRg.Value = xArr（xFArr）
xRg = xRg.Offset（ColumnOffset：= 1）を設定します
終了する場合
次へ
終了する場合
次へ
次へ
終了する場合
Application.ScreenUpdating = True
End Subの

カンマに基づいてデータを列に変換する必要がある場合、どのような変更を行う必要がありますか？

私はこれを使用して動作しますが、各シートは毎日のログファイルと同じ情報であるため、すべてを XNUMX つのシートに保存したいと思います。
だから私は組み合わせる必要があります
フォルダ内のすべてのアイテムを XNUMX つのシートに
サブImportCSVsWithReference（）
'UpdatebyKutoolsforExcel20151214
ワークブックとしてxWbを暗くする
xToBookをワークブックとして薄暗くする
文字列としての薄暗いxStrPath
xFileDialog を FileDialog として薄暗くする
文字列としての薄暗いxFile
新しいコレクションとしての薄暗いxFiles
薄暗い私は長く
薄暗いxIntRowAsLong
薄暗いxFNum、xFArr As Long
Dim xStrValue を文字列として
範囲としての薄暗いxRg
薄暗いxArr
エラー時GoToErrHandler
xFileDialog = Application.FileDialog（msoFileDialogFolderPicker）を設定します
xFileDialog.AllowMultiSelect = False
xFileDialog.Title="フォルダを選択[KutoolsforExcel]"
xFileDialog.Show=-1の場合
xStrPath = xFileDialog.SelectedItems（1）
終了する場合
xStrPath = ""の場合、Subを終了します
If Right（xStrPath、1）<> "\" Then xStrPath = xStrPath＆ "\"
xSht = ThisWorkbook.ActiveSheet を設定します
If MsgBox("Clear the existing sheet before importing?", vbYesNo, "Kutools for Excel") = vbYes Then xSht.UsedRange.Clear
Application.ScreenUpdating = False
xFile = Dir(xStrPath & "\" & "*.log")
xFile <> ""
Set xWb = Workbooks.Open(xStrPath & "\" & xFile)
ActiveSheet.UsedRange.Copy xSht.Range("A" & Rows.Count).End(xlUp).Offset(1)
xWb.Close False
xFile = Dir
ループ
Application.ScreenUpdating = True
サブを終了
ErrHandler：
MsgBox「txtファイルなし」、「Kutools for Excel」
End Subの

そして、これはスペースを使用して各列に dd します

Sub ImportTextToExcel（）
'UpdatebyExtendoffice20180911
ワークブックとしてxWbを暗くする
xToBookをワークブックとして薄暗くする
文字列としての薄暗いxStrPath
xFileDialog を FileDialog として薄暗くする
文字列としての薄暗いxFile
新しいコレクションとしての薄暗いxFiles
薄暗い私は長く
薄暗いxIntRowAsLong
薄暗いxFNum、xFArr As Long
Dim xStrValue を文字列として
範囲としての薄暗いxRg
薄暗いxArr
xFileDialog = Application.FileDialog（msoFileDialogFolderPicker）を設定します
xFileDialog.AllowMultiSelect = False
xFileDialog.Title="フォルダを選択[KutoolsforExcel]"
xFileDialog.Show=-1の場合
xStrPath = xFileDialog.SelectedItems（1）
終了する場合
xStrPath = ""の場合、Subを終了します
If Right（xStrPath、1）<> "\" Then xStrPath = xStrPath＆ "\"
xFile = Dir（xStrPath＆ "* .txt"）
xFile=""の場合
MsgBox「ファイルが見つかりません」、vbInformation、「KutoolsforExcel」
サブを終了
終了する場合
xFile <> ""
xFiles.Add xFile、xFile
xFile = Dir（）
ループ
xToBook=ThisWorkbookを設定します
エラーで次の再開
Application.ScreenUpdating = False
xFiles.Count>0の場合Then

I=1の場合xFiles.Countへ
xWb = Workbooks.Open（xStrPath＆xFiles.Item（I））を設定します
xWb.Worksheets（1）.Copy after：= xToBook.Sheets（xToBook.Sheets.Count）

ActiveSheet.Name = xWb.Name

xWb.Close False
xIntRow = ActiveCell.CurrentRegion.Rows.Count
xFNum=1の場合xIntRow
xRg = ActiveSheet.Range（ "A"＆xFNum）を設定します
xArr = Split（xRg.Text、 ""）
UBound（xArr）>0の場合
xFArr = 0の場合UBound（xArr）へ
If xArr（xFArr）<> "" Then
xRg.Value = xArr（xFArr）
xRg = xRg.Offset（ColumnOffset：= 1）を設定します
終了する場合
次へ
終了する場合
次へ
次へ
終了する場合
Application.ScreenUpdating = True
End Subの

Find and Replace fuctuonを使用して、最初にコンマをスペースに置き換え、上記のいずれかの方法を適用してExcelファイルに変換できます。

すべてのテキストファイルをXNUMXつのシートに結合するという意味ですか？

こんにちは、Davinder、以下の vba コードを試すことができます。

Sub ImportCSVsWithReference()
'UpdatebyKutoolsforExcel20151214
    Dim xSht  As Worksheet
    Dim xWb As Workbook
    Dim xStrPath As String
    Dim xFileDialog As FileDialog
    Dim xFile As String
    On Error GoTo ErrHandler
    Set xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
    xFileDialog.AllowMultiSelect = False
    xFileDialog.Title = "Select a folder [Kutools for Excel]"
    If xFileDialog.Show = -1 Then
        xStrPath = xFileDialog.SelectedItems(1)
    End If
    If xStrPath = "" Then Exit Sub
    Set xSht = ThisWorkbook.ActiveSheet
    If MsgBox("Clear the existing sheet before importing?", vbYesNo, "Kutools for Excel") = vbYes Then xSht.UsedRange.Clear
    Application.ScreenUpdating = False
    xFile = Dir(xStrPath & "\" & "*.txt")
    Do While xFile <> ""
        Set xWb = Workbooks.Open(xStrPath & "\" & xFile)
        ActiveSheet.UsedRange.Copy xSht.Range("A" & Rows.Count).End(xlUp).Offset(1)
        xWb.Close False
        xFile = Dir
    Loop
    Application.ScreenUpdating = True
    Exit Sub
ErrHandler:
    MsgBox "no txt files", , "Kutools for Excel"
End Sub

このコードは機能していますが、それでも一部を変更する必要があります。

※新しいシートを開かずに同じシートに貼り付けて、時間がかかるのでコピーしてほしい。

*インポートされたtxtファイルが文字Aで始まる場合はシート1に貼り付けられ、文字Bで始まる場合はシート2にインポートされる場合は条件付きifを挿入する必要があります


サブtestcopy3（）
ワークブックとしてxWbを暗くする
xToBookをワークブックとして薄暗くする
文字列としての薄暗いxStrPath
xFileDialog を FileDialog として薄暗くする
文字列としての薄暗いxFile
新しいコレクションとしての薄暗いxFiles
ディム・アイ・アス・ロング
LastRowを暗くする
範囲として暗くする
xFileDialog = Application.FileDialog（msoFileDialogFolderPicker）を設定します
xFileDialog.AllowMultiSelect = False
xFileDialog.Title="フォルダを選択[KutoolsforExcel]"
xFileDialog.Show=-1の場合
xStrPath = xFileDialog.SelectedItems（1）
終了する場合
xStrPath = ""の場合、Subを終了します
If Right（xStrPath、1）<> "\" Then xStrPath = xStrPath＆ "\"
xFile = Dir（xStrPath＆ "* .txt"）
xFile=""の場合
MsgBox「ファイルが見つかりません」、vbInformation、「KutoolsforExcel」
サブを終了
終了する場合
xFile <> ""
xFiles.Add xFile、xFile
xFile = Dir（）
ループ
Range（ "N2"）。Select
xToBook=ThisWorkbookを設定します
xFiles.Count>0の場合Then
i=1の場合xFiles.Countへ
xWb = Workbooks.Open（xStrPath＆xFiles.Item（i））を設定します
xWb.Activate
'txtデータの選択とコピー
Range（Selection、Selection.End（xlDown））。Select
選択。コピー
xToBook.Activate
ActiveSheet.貼り付け
Selection.End（xlDown）.Offset（1）.Select
エラーで次の再開
エラー時GoTo0
xWb.Close False
次へ
終了する場合
End Subの

すみません、私の手は結ばれています

申し訳ありませんが、繰り返しインポートしないように注意してください。

Pooja、Kutools for Excelの先行ゼロの削除機能を試して、インポート後にすべての先行ゼロを選択から削除することができます。

先行ゼロを保持したい場合は、セル形式でテキスト形式としてフォーマットできます。

こんにちは、以下のコードを試してください

Sub Test()
    'UpdatebyExtendoffice 10/26/2022
    Dim xWb As Workbook
    Dim xToBook As Workbook
    Dim xStrPath As String
    Dim xFileDialog As FileDialog
    Dim xFile As String
    Dim xFiles As New Collection
    Dim I As Long
    Dim J As Long
    Dim xRg As Range
    Dim xSaveRg As Range
    Dim xSh As Worksheet
    
    Set xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
    xFileDialog.AllowMultiSelect = False
    xFileDialog.Title = "Select a folder [Kutools for Excel]"
    If xFileDialog.Show = -1 Then
        xStrPath = xFileDialog.SelectedItems(1)
    End If
    If xStrPath = "" Then Exit Sub
    If Right(xStrPath, 1) <> "\" Then xStrPath = xStrPath & "\"
    xFile = Dir(xStrPath & "*.txt")
    If xFile = "" Then
        MsgBox "No files found", vbInformation, "Kutools for Excel"
        Exit Sub
    End If
    Do While xFile <> ""
        xFiles.Add xFile, xFile
        xFile = Dir()
    Loop
    Set xToBook = ThisWorkbook
    Set xSh = xToBook.Sheets.Add
    Set xRg = xSh.Range("A1")
    J = 1
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    If xFiles.Count > 0 Then
        For I = 1 To xFiles.Count
            Set xWb = Workbooks.Open(xStrPath & xFiles.Item(I))
            Set xSaveRg = xWb.Worksheets(1).UsedRange
            J = xSaveRg.Rows.Count + 1 + J
            Debug.Print xRg.Address
            xSaveRg.Copy Destination:=xRg
            On Error Resume Next
            xWb.Close False
            
            Set xRg = xSh.Cells(J, 1)
        Next
    End If
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub

こんにちは、ダニエル、以下のコードを試してください。すべてのテキスト ファイルを Txt という名前の XNUMX つのシートにインポートします。
注意: テキスト名が既存のシート名と同じ場合、テキスト ファイルがインポートされない場合があります。

Sub ImportTextToExcel2()

'UpdatebyExtendoffice20230106

Dim xWb As Workbook

Dim xToBook As Workbook

Dim xStrPath As String

Dim xFileDialog As FileDialog

Dim xFile As String

Dim xFiles As New Collection

Dim I As Long

Dim xIntRow As Long

Dim xFNum, xFArr As Long

Dim xStrValue As String

Dim xRg As Range

Dim xArr

Dim xRowL, xRowH As Integer

Dim xTxtWS, xWSD As Worksheet

Dim xTxtWS_Rg As Range

Set xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)

xFileDialog.AllowMultiSelect = False

xFileDialog.Title = "Select a folder [Kutools for Excel]"

If xFileDialog.Show = -1 Then

xStrPath = xFileDialog.SelectedItems(1)

End If

If xStrPath = "" Then Exit Sub

If Right(xStrPath, 1) <> "\" Then xStrPath = xStrPath & "\"

xFile = Dir(xStrPath & "*.txt")

If xFile = "" Then

MsgBox "No files found", vbInformation, "Kutools for Excel"

Exit Sub

End If

Do While xFile <> ""

xFiles.Add xFile, xFile

xFile = Dir()

Loop

Set xToBook = ThisWorkbook

On Error Resume Next

Set xTxtWS = xToBook.Worksheets("Txt")

If IsNull(xTxtWS) Or IsEmpty(xTxtWS) Then

    Set xTxtWS = xToBook.Worksheets.Add

    xTxtWS.Name = "Txt"

End If

Application.ScreenUpdating = False

Application.DisplayAlerts = False

xTxtWS.Activate

If xFiles.Count > 0 Then

xRowL = 1

For I = 1 To xFiles.Count

Set xWb = Workbooks.Open(xStrPath & xFiles.Item(I))

xWb.Worksheets(1).Copy after:=xToBook.Sheets(xToBook.Sheets.Count)

Set xWSD = xToBook.Sheets(xToBook.Sheets.Count)

xTxtWS.Activate

xWb.Close False

xIntRow = xWSD.UsedRange.CurrentRegion.Rows.Count

    For xFNum = 1 To xIntRow

        Set xRg = xWSD.Range("A" & xFNum)

        xArr = Split(xRg.Text, " ")

        Set xTxtWS_Rg = xTxtWS.Cells.Range("A" & xRowL)

'        If UBound(xArr) > 0 Then

            For xFArr = 0 To UBound(xArr)

                If xArr(xFArr) <> "" Then

                xTxtWS_Rg.Value = xArr(xFArr)

                Set xTxtWS_Rg = xTxtWS_Rg.Offset(ColumnOffset:=1)

                End If

            Next

'        End If

xRowL = xRowL + 1

    Next

xWSD.Delete

Next

End If

Application.ScreenUpdating = True

Application.DisplayAlerts = True

End Sub