Deseja manter o espaço (delimitadores) após converter os arquivos de texto em planilhas?

Você poderia fazer o upload do arquivo de texto e o resultado que deseja para mim?

Olá, Des e PB Rama Murty, o código abaixo pode dividir dados em colunas com base em espaço ou tabulação ao importar arquivo de texto para planilhas. Você pode tentar.

Sub ImportarTextoParaExcel()
'Atualizar porExtendoffice20180911
Dim xWb como pasta de trabalho
Dim xToBook como pasta de trabalho
Dim xStrPath como String
Dim xFileDialog como FileDialog
Dim xArquivo como String
Dim xFiles como nova coleção
Escurecer eu enquanto
Dim xIntRow por muito tempo
Dim xFNum, xFArr Enquanto
Dim xStrValue como String
Dim xRg como intervalo
Dim xArr
Definir xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
xFileDialog.AllowMultiSelect = Falso
xFileDialog.Title = "Selecione uma pasta [Kutools for Excel]"
Se xFileDialog.Show = -1 Então
xStrPath = xFileDialog.SelectedItems(1)
Se acabar
If xStrPath = "" Então Exit Sub
If Right(xStrPath, 1) <> "\" Então xStrPath = xStrPath & "\"
xFile = Dir(xStrPath & "*.txt")
Se xArquivo = "" Então
MsgBox "Nenhum arquivo encontrado", vbInformation, "Kutools for Excel"
Exit Sub
Se acabar
Faça While xFile <> ""
xFiles. Adicionar xFile, xFile
xArquivo = Dir()
laço
Definir xToBook = ThisWorkbook
On Error Resume Next
Application.ScreenUpdating = False
Se xFiles.Count > 0 Então

Para I = 1 Para xFiles.Count
Set xWb = Workbooks.Open(xStrPath & xFiles.Item(I))
xWb.Worksheets(1).Copiar após:=xToBook.Sheets(xToBook.Sheets.Count)

ActiveSheet.Name = xWb.Name

xWb.Fechar Falso
xIntRow = ActiveCell.CurrentRegion.Rows.Count
Para xFNum = 1 Para xIntRow
Set xRg = ActiveSheet.Range("A" & xFNum)
xArr = Split(xRg.Text, " ")
Se UBound(xArr) > 0 Então
Para xFArr = 0 Para UBound(xArr)
Se xArr(xFArr) <> "" Então
xRg.Value = xArr(xFArr)
Definir xRg = xRg.Offset(ColumnOffset:=1)
Se acabar
Seguinte
Se acabar
Seguinte
Seguinte
Se acabar
Application.ScreenUpdating = True
End Sub

Quais alterações precisam ser feitas se eu precisar de dados em colunas com base em vírgula?

Eu usei isso e funciona, mas gostaria que tudo fosse salvo em uma planilha, pois cada planilha contém as mesmas informações, são apenas arquivos de log de cada dia.
então eu preciso combinar o
todos os itens da pasta em uma folha
Sub ImportaçãoCSVsWithReference()
'UpdatebyKutoolsforExcel20151214
Dim xWb como pasta de trabalho
Dim xToBook como pasta de trabalho
Dim xStrPath como String
Dim xFileDialog como FileDialog
Dim xArquivo como String
Dim xFiles como nova coleção
Escurecer eu enquanto
Dim xIntRow por muito tempo
Dim xFNum, xFArr Enquanto
Dim xStrValue como String
Dim xRg como intervalo
Dim xArr
Em caso de erro Ir para ErrHandler
Definir xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
xFileDialog.AllowMultiSelect = Falso
xFileDialog.Title = "Selecione uma pasta [Kutools for Excel]"
Se xFileDialog.Show = -1 Então
xStrPath = xFileDialog.SelectedItems(1)
Se acabar
If xStrPath = "" Então Exit Sub
If Right(xStrPath, 1) <> "\" Então xStrPath = xStrPath & "\"
Definir xSht = ThisWorkbook.ActiveSheet
If MsgBox("Limpar a planilha existente antes de importar?", vbYesNo, "Kutools for Excel") = vbYes Then xSht.UsedRange.Clear
Application.ScreenUpdating = False
xFile = Dir(xStrPath & "\" & "*.log")
Faça While xFile <> ""
Set xWb = Workbooks.Open(xStrPath & "\" & xFile)
ActiveSheet.UsedRange.Copy xSht.Range("A" & Rows.Count).End(xlUp).Offset(1)
xWb.Fechar Falso
xArquivo = Dir
laço
Application.ScreenUpdating = True
Exit Sub
ErrHandler:
MsgBox "nenhum arquivo txt", , "Kutools for Excel"
End Sub

e este que usa espaços para adicionar a cada coluna

Sub ImportarTextoParaExcel()
'Atualizar porExtendoffice20180911
Dim xWb como pasta de trabalho
Dim xToBook como pasta de trabalho
Dim xStrPath como String
Dim xFileDialog como FileDialog
Dim xArquivo como String
Dim xFiles como nova coleção
Escurecer eu enquanto
Dim xIntRow por muito tempo
Dim xFNum, xFArr Enquanto
Dim xStrValue como String
Dim xRg como intervalo
Dim xArr
Definir xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
xFileDialog.AllowMultiSelect = Falso
xFileDialog.Title = "Selecione uma pasta [Kutools for Excel]"
Se xFileDialog.Show = -1 Então
xStrPath = xFileDialog.SelectedItems(1)
Se acabar
If xStrPath = "" Então Exit Sub
If Right(xStrPath, 1) <> "\" Então xStrPath = xStrPath & "\"
xFile = Dir(xStrPath & "*.txt")
Se xArquivo = "" Então
MsgBox "Nenhum arquivo encontrado", vbInformation, "Kutools for Excel"
Exit Sub
Se acabar
Faça While xFile <> ""
xFiles. Adicionar xFile, xFile
xArquivo = Dir()
laço
Definir xToBook = ThisWorkbook
On Error Resume Next
Application.ScreenUpdating = False
Se xFiles.Count > 0 Então

Para I = 1 Para xFiles.Count
Set xWb = Workbooks.Open(xStrPath & xFiles.Item(I))
xWb.Worksheets(1).Copiar após:=xToBook.Sheets(xToBook.Sheets.Count)

ActiveSheet.Name = xWb.Name

xWb.Fechar Falso
xIntRow = ActiveCell.CurrentRegion.Rows.Count
Para xFNum = 1 Para xIntRow
Set xRg = ActiveSheet.Range("A" & xFNum)
xArr = Split(xRg.Text, " ")
Se UBound(xArr) > 0 Então
Para xFArr = 0 Para UBound(xArr)
Se xArr(xFArr) <> "" Então
xRg.Value = xArr(xFArr)
Definir xRg = xRg.Offset(ColumnOffset:=1)
Se acabar
Seguinte
Se acabar
Seguinte
Seguinte
Se acabar
Application.ScreenUpdating = True
End Sub

Você pode usar a função Localizar e substituir para substituir a vírgula por espaço primeiro e aplicar um dos métodos acima para convertê-lo em arquivo do Excel.

Você quer combinar todos os arquivos de texto em uma folha?

Oi, Davinder, você pode tentar abaixo do código 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

Eu tenho esse código funcionou para mim, mas ainda assim, preciso alterar alguns nele.

*Quero colar na mesma planilha sem abrir uma nova planilha e depois copiá-la, pois leva mais tempo.

*precisa inserir uma condicional se os arquivos txt importados forem colados na folha 1 se começarem com a letra A e importados para a Folha 2 se começarem com a letra B


Subtestcopy3()
Dim xWb como pasta de trabalho
Dim xToBook como pasta de trabalho
Dim xStrPath como String
Dim xFileDialog como FileDialog
Dim xArquivo como String
Dim xFiles como nova coleção
Dim i tanto tempo
Escurecer a última linha por muito tempo
Dim Rng como intervalo
Definir xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
xFileDialog.AllowMultiSelect = Falso
xFileDialog.Title = "Selecione uma pasta [Kutools for Excel]"
Se xFileDialog.Show = -1 Então
xStrPath = xFileDialog.SelectedItems(1)
Se acabar
If xStrPath = "" Então Exit Sub
If Right(xStrPath, 1) <> "\" Então xStrPath = xStrPath & "\"
xFile = Dir(xStrPath & "*.txt")
Se xArquivo = "" Então
MsgBox "Nenhum arquivo encontrado", vbInformation, "Kutools for Excel"
Exit Sub
Se acabar
Faça While xFile <> ""
xFiles. Adicionar xFile, xFile
xArquivo = Dir()
laço
Intervalo("N2").Selecione
Definir xToBook = ThisWorkbook
Se xFiles.Count > 0 Então
Para i = 1 Para xFiles.Count
Set xWb = Workbooks.Open(xStrPath & xFiles.Item(i))
xWb. Ativar
'Selecionando e copiando os dados txt
Faixa(Seleção, Seleção.Fim(xlPara Baixo)).Selecione
Selection.Copy
xToBook.Activate
ActiveSheet.Paste
Seleção.End(xlDown).Offset(1).Selecionar
On Error Resume Next
Em erro GoTo 0
xWb.Fechar Falso
Seguinte
Se acabar
End Sub

Desculpe, minhas mãos estão atadas

Desculpe, Harsh, apenas tome cuidado para evitar a importação repetida.

Pooja, você pode tentar a função Remove Leading Zeros do Kutools for Excel para remover todos os zeros à esquerda da seleção após a importação.

Se você quiser manter os zeros à esquerda, você pode formatá-los como formato de texto pelo formato de célula.

Olá, tente abaixo o código

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

Olá, Daniel, tente o código abaixo, ele importa todos os arquivos de texto em uma planilha chamada Txt.
Observe que: se o nome do texto for igual ao nome da planilha existente, o arquivo de texto pode não ser importado.

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