Copy data from text file to Worksheet With VBA

[Abhishek A]

I have multiple text files saved in the Path “C:\Users\E5554593\Desktop\New folder”. I need to import the data from text files to excel. Each file data should come in separate tabs, Tab name will be same as text file name.

Can anyone help me out with this please.. Its taking lot of time

 

[Abhishek A]

I use below code to import data from Word docs.. Its working perfectly fine.. but not working from text files...



Code:-

Sub GetDocContent()
Application.ScreenUpdating = False
Application.DisplayStatusBar = False
Application.EnableEvents = False
Dim wdApp As New Word.Application, wdDoc As Word.Document
Dim strFolder As String, strFile As String, lRow As Long
Dim WkSht As Worksheet: Set WkSht = ActiveSheet
strFolder = "C:\Users\" & Environ("UserName") & "\Downloads\"
strFile = Dir(strFolder & "*.doc", vbNormal)
While strFile <> ""
  Set wdDoc = wdApp.Documents.Open(Filename:=strFolder & strFile, AddToRecentFiles:=False, ReadOnly:=True, Visible:=False)
  lRow = WkSht.UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1
  With wdDoc
    .Range.Copy
    WkSht.Paste WkSht.Range("A" & lRow)
    .Close SaveChanges:=False
  End With
  strFile = Dir()
Wend
wdApp.Quit

Set wdDoc = Nothing: Set wdApp = Nothing: Set WkSht = Nothing
Application.ScreenUpdating = True
Application.DisplayStatusBar = False
Application.EnableEvents = False
End Sub

 

[shrivallabha]

See if this code helps you. It should create a new unsaved workbook every time you run this macro...

Public Sub ReadTextFilesInAFolder()
Const cStrPath As String = "C:\Users\E5554593\Desktop\New folder" '\\Change this path to suit
Const ForReading = 1, ForWriting = 2
Dim objFSO As Object '\\ FileSystemObject
Dim objFile As Object '\\ File
Dim objTxFl As Object '\\ TextFile
Dim wkbNew As Workbook
Dim wksNew As Worksheet
Dim varContent
Dim lngCnt As Long: lngCnt = 1

Set objFSO = CreateObject("Scripting.FileSystemObject")
Set wkbNew = Application.Workbooks.Add
For Each objFile In objFSO.GetFolder(cStrPath).Files
    If objFile.Type = "Text Document" Then '\\ See if this condition works on your machine correctly
        Set objTxFl = objFSO.OpenTextFile(objFile.Path, ForReading, False, TristateUseDefault)
        varContent = Split(objTxFl.ReadAll, vbCrLf)
        If lngCnt > wkbNew.Sheets.Count Then wkbNew.Sheets.Add After:=wkbNew.Sheets(wkbNew.Sheets.Count)
        Set wksNew = wkbNew.Sheets(lngCnt)
        wksNew.Name = objFile.Name
        wksNew.Range("A1").Resize(UBound(varContent), 1).Value = varContent
        lngCnt = lngCnt + 1
    End If
Next objFile
'\\ Release objects from memory
Set objTxFl = Nothing: Set objFile = Nothing: Set objFSO = Nothing
Set wkbNew = Nothing: Set wksNew = Nothing
End Sub

 

[Abhishek A]

Its working but not as expected..
1. complete data is not coping to excel
2. tab names should not include .txt
3. Blank rows needs to deleted and the first column as well
3. I have uploaded a sample file for reference

 

[AlanSidman]

You could import each file into Power Query and then Load and Close each to a workbook. Fairly quick and easy.

 

[shrivallabha]

Its working but not as expected..
1. complete data is not coping to excel
2. tab names should not include .txt
3. Blank rows needs to deleted and the first column as well
3. I have uploaded a sample file for reference

For first two items, modify following lines:

        wksNew.Name = objFile.Name
        wksNew.Range("A1").Resize(UBound(varContent), 1).Value = varContent

to

        wksNew.Name = Replace(objFile.Name, ".txt", "")
        wksNew.Range("A1").Resize(UBound(varContent) + 1, 1).Value = Application.Transpose(varContent)

For 3 & 4, you should've taken efforts to describe your requirements when you posted for the first time. Now please try to modify the code and get solution yourself.