CODEWITHSUNDEEP
vbaexcel
lvars
lvars

Reputation: 77

Import Multiple text files into workbook where worksheet name matches text file name

Introduction: With continuation to my previous question, initially, my previous code (with the help from Stack exchange experts) works fine.

Problem: But next time when I import the files again (which I have to do monthly), it creates duplicate Sheets. So I would like to modify my project as follows.

On clicking "Import text files" button, the VBA code:

  1. Check the existing Workbook for the sheet names matching the text file name. If existing, clear the contents of the sheet and copy the data into the sheet.

  2. For example, If my text file names are like "Data_REQ1", "Data_REQ2" and so on until Data_REQ30, the code should check for sheets starting with Data_REQ1, if exists clear the contents, copy the data from text file Data_REQ1 into the sheet Data_REQ1 and so on for other sheets. Pseudo code: 

    Check Sheets existence    
If Sheet name exists Then     
    Clear contents
    Copy the data from text file having sheet name=textfile name         
Else                
    Create the Sheet and import the data into the sheet

Here is my full code 

Sub copydata()

    Dim FilesToOpen
    Dim x As Integer
    Dim wkbAll As Workbook
    Dim sDelimiter As String
    Dim ws As Worksheet
    Dim lastCol As Integer
    Dim lastRow As Integer
    Dim TextFileName As String

    On Error GoTo ErrHandler
    Application.ScreenUpdating = False

    sDelimiter = "|"

    FilesToOpen = Application.GetOpenFilename _
      (FileFilter:="Text Files (*.txt), *.txt", _
      MultiSelect:=True, Title:="Text Files to Open")

    If TypeName(FilesToOpen) = "Boolean" Then
        MsgBox "No Files were selected"
        GoTo ExitHandler
    End If

    'Open First text File then format the data with delimiter and copy the data

    x = 1
    With Workbooks.Open(filename:=FilesToOpen(x))
        TextFileName = Sheets(1).Name
        .Worksheets(1).Columns("A:A").TextToColumns _
            Destination:=Range("A1"), DataType:=xlDelimited, _
            TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, _
            Tab:=False, Semicolon:=False, Comma:=False, Space:=False, _
            Other:=True, OtherChar:="|"
        lastCol = Sheets(TextFileName).Range("a1").End(xlToRight).Column
        lastRow = Sheets(TextFileName).Cells(65536, lastCol).End(xlUp).Row
        Selection.Copy
        .Close False

    'clear the contents of the sheets, copy the data into the sheet with same name as text file

        With ThisWorkbook.Worksheets(TextFileName)
            lastCol = Sheets(TextFileName).Range("a1").End(xlToRight).Column
            lastRow = Sheets(TextFileName).Cells(65536, lastCol).End(xlUp).Row
            Sheets(TextFileName).Range("a1", ActiveSheet.Cells(lastRow, lastCol)).Select
            Selection.ClearContents
            Sheets(TextFileName).Range("A1").PasteSpecial
        End With

    End With

    'This loop is for other files , if the above code works for 1 file, I will change this code for other files
    x = x + 1
    While x <= UBound(FilesToOpen)
        With Workbooks.Open(filename:=FilesToOpen(x))
            .Worksheets(1).Columns("A:A").TextToColumns _
                Destination:=Range("A1"), DataType:=xlDelimited, _
                TextQualifier:=xlDoubleQuote, _
                ConsecutiveDelimiter:=False, _
                Tab:=False, Semicolon:=False, _
                Comma:=False, Space:=False, _
                Other:=True, OtherChar:=sDelimiter
            .Sheets(1).Move After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)

        End With
        x = x + 1
    Wend
    Call fitWidth(ws)
    wkbAll.Save
ExitHandler:
    Application.ScreenUpdating = True
    Set wkbAll = Nothing
    Exit Sub

ErrHandler:
    MsgBox Err.Description
    Resume ExitHandler
End Sub

Sub fitWidth(ws As Worksheet)
    For Each ws In Sheets
        If LCase(ws.Name) Like "data_req*" Then
            ws.Cells.EntireColumn.AutoFit
        End If
    Next
End Sub

Here is the code which I tried to change from previous version

Previous version:

With Workbooks.Open(filename:=FilesToOpen(x))
    .Worksheets(1).Columns("A:A").TextToColumns _
        Destination:=Range("A1"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, _
        Tab:=False, Semicolon:=False, Comma:=False, Space:=False, _
        Other:=True, OtherChar:="|"
    .Sheets(1).Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
    .Close False

Present Version

x = 1
With Workbooks.Open(fileName:=FilesToOpen(x))
    TextFileName = Sheets(1).Name
    .Worksheets(1).Columns("A:A").TextToColumns _
        Destination:=Range("A1"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, _
        Tab:=False, Semicolon:=False, Comma:=False, Space:=False, _
        Other:=True, OtherChar:="|"
    lastCol = Sheets(TextFileName).Range("a1").End(xlToRight).Column
    lastRow = Sheets(TextFileName).Cells(65536, lastCol).End(xlUp).Row
    Selection.Copy
    .Close False

'clear the contents of the sheets, copy the data into the sheet with same >     name as text file

With ThisWorkbook.Worksheets(TextFileName)
    lastCol = Sheets(TextFileName).Range("a1").End(xlToRight).Column
    lastRow = Sheets(TextFileName).Cells(65536, lastCol).End(xlUp).Row
    Sheets(TextFileName).Range("a1", ActiveSheet.Cells(lastRow, lastCol)).Select
    Selection.ClearContents
    Sheets(TextFileName).Range("A1").PasteSpecial
End With

My Request: With this change, I am able to clear contents, but not pasting the data. Any suggestions or any code better than this code will be appreciated.

Upvotes: 4

Views: 2653

Answers (1)

Parfait
Parfait

Reputation: 107567

Consider using QueryTables to import text files. No need to copy/paste across temp workbooks:

Sub ImportTXTFiles()
    Dim fso As Object
    Dim xlsheet As Worksheet
    Dim qt As QueryTable
    Dim txtfilesToOpen As Variant, txtfile As Variant

    Application.ScreenUpdating = False
    Set fso = CreateObject("Scripting.FileSystemObject")

    txtfilesToOpen = Application.GetOpenFilename _
                 (FileFilter:="Text Files (*.txt), *.txt", _
                  MultiSelect:=True, Title:="Text Files to Open")    

    For Each txtfile In txtfilesToOpen
        ' FINDS EXISTING WORKSHEET
        For Each xlsheet In ThisWorkbook.Worksheets
            If xlsheet.Name = Replace(fso.GetFileName(txtfile), ".txt", "") Then
                xlsheet.Activate
                GoTo ImportData
            End If
        Next xlsheet

        ' CREATES NEW WORKSHEET IF NOT FOUND
        Set xlsheet = ThisWorkbook.Worksheets.Add( _
                             After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
        xlsheet.Name = Replace(fso.GetFileName(txtfile), ".txt", "")
        xlsheet.Activate
        GoTo ImportData

ImportData:
        ' DELETE EXISTING DATA
        ActiveSheet.Range("A:Z").EntireColumn.Delete xlShiftToLeft

        ' IMPORT DATA FROM TEXT FILE
        With ActiveSheet.QueryTables.Add(Connection:="TEXT;" & txtfile, _
          Destination:=ActiveSheet.Cells(1, 1))
            .TextFileParseType = xlDelimited
            .TextFileConsecutiveDelimiter = False
            .TextFileTabDelimiter = False
            .TextFileSemicolonDelimiter = False
            .TextFileCommaDelimiter = False
            .TextFileSpaceDelimiter = False
            .TextFileOtherDelimiter = "|"

            .Refresh BackgroundQuery:=False
        End With

        For Each qt In ActiveSheet.QueryTables
            qt.Delete
        Next qt
    Next txtfile

    Application.ScreenUpdating = True
    MsgBox "Successfully imported text files!", vbInformation, "SUCCESSFUL IMPORT"

    Set fso = Nothing
End Sub

Upvotes: 3

Related Questions