asked on

Copy text files into separate worksheets in Excel

I need to have my code below modified to have 1 to several text files copied and pasted into different sheets in a template workbook. Each text file will list an aquisition ID in the first column which will be all the same for that text file. I need that text with aq ID copied and pasted into the template file in a new worksheet with that aq ID as the tab name. There can be 1 to several text files that I need this done for. The naming convention for the text files are r99997_1_n.txt with the n being a different number (r99997_1_1.txt, r99997_1_2.txt, r99997_1_3.txt,.....) All of the texts with that naming convention needs to be copied over to excel.

My orig code when I thought the aquisition IDs were going to be in 1 text file:
Dim stPath As String
Dim stText As String
Dim stTemp As String

stPath = "H:\"
stText = "r99997_1_1.txt"
stTemp = "Template Report ACQ Result.xlsx"

Workbooks.Open Filename:=stPath & "Templates\" & stTemp
With ActiveSheet.QueryTables.Add(Connection:="TEXT;H:\" & stText, Destination:=Range("$A$7"))
.Name = stText
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = False
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
.TextFilePlatform = 437
.TextFileStartRow = 1
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = False
.TextFileTabDelimiter = True
.TextFileSemicolonDelimiter = False
.TextFileCommaDelimiter = False
.TextFileSpaceDelimiter = False
.TextFileColumnDataTypes = Array(1, 1, 1, 1, 1, 1, 1)
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
End With

Dim rCheck As Range
Dim rFilter As Range
Dim cUnique As New Collection
Dim i As Long
Dim CurrentCell As Range
Dim wsTarget As Worksheet
Dim dtRpt As Date
Dim wsOrig As Worksheet

Set wsOrig = Worksheets("Loan Level")
dtRpt = Date

With wsOrig
.Range("A1").Value = dtRpt
Set rCheck = .Range(.Cells(6, "A"), .Cells(.rows.Count, "A").End(xlUp))
Set rFilter = .Range(.Cells(7, "A"), .Cells(.rows.Count, "A").End(xlUp))
On Error Resume Next
For Each CurrentCell In rFilter.Cells
cUnique.Add CurrentCell.Value, CurrentCell.Value
Next CurrentCell
On Error GoTo 0
End With

For i = 1 To cUnique.Count

Set wsTarget = Workbooks(stTemp).Sheets.Add(After:=Sheets(Sheets.Count))
On Error Resume Next
wsTarget.Name = cUnique(i)
If Err.Number <> 0 Then
Err.Clear
End If

wsOrig.rows("1:6").Copy
wsTarget.Range("A1").PasteSpecial xlPasteAllUsingSourceTheme
wsTarget.Range("A1").PasteSpecial xlPasteColumnWidths

wsOrig.Shapes.Range(Array("Picture 2")).Copy
wsTarget.Paste

ActiveWindow.DisplayGridlines = False
Range("A1").Select
rCheck.AutoFilter Field:=1, Criteria1:=cUnique(i)
rFilter.SpecialCells(xlCellTypeVisible).EntireRow.Copy wsTarget.rows(7)
rCheck.Parent.AutoFilterMode = False

On Error GoTo 0

Next i

Sheets("Loan Level").Delete
Sheets("Criteria").Move After:=Sheets(Sheets.Count)
Worksheets(1).Select
Workbooks(stTemp).SaveAs stPath & "ACQ Call Result " & Format(dtRpt, "mmddyy") & ".xlsx"
ActiveWorkbook.Close

Robberbaron (robr)

dont have anything to test against...

but i have broken down the first part into a couple of routines; see how they work for you

Option Explicit
Sub MakeSheets()
    
    Dim stPath As String
    Dim stText As String
    Dim stTemp As String
    Dim fl As String, aqId As String
    
    stPath = "H:\" & "Templates\"
    stText = "r99997_1_*.txt"
    
    stTemp = "Template Report ACQ Result.xlsx"
    
    Dim wbActive As Workbook, wsTemplate As Worksheet
    Dim wsActive As Worksheet
    
    Set wbActive = Workbooks.Open(Filename:=stPath & fl)
    
    'assume that the template is active sheet.  better to name it
    Set wsTemplate = wbActive.ActiveSheet

    
    fl = Dir$(stText)
    'find all matching files
    Do While fl <> ""
        'create a new sheet from template
        wsTemplate.Copy Before:=wsTemplate
        Set wsActive = wbActive.ActiveSheet  ' the new sheet
        aqId = LoadTxtFile(wsActive, stPath & fl)
        wsActive.Name = aqId
    Loop
    
End Sub
    
Function LoadTxtFile(wsTarget As Worksheet, txtFilename As String) As String

    'Workbooks.Open Filename:=stPath & "Templates\" & stTemp
        'With ActiveSheet.QueryTables.Add(Connection:="TEXT;H:\" & stText, Destination:=Range("$A$7"))
        Dim rngDest As Range
        Set rngDest = Range("$A$7")
        With wsTarget.QueryTables.Add(Connection:="TEXT;" & txtFilename, Destination:=rngDest)
            .Name = stText
            .FieldNames = True
            .RowNumbers = False
            .FillAdjacentFormulas = False
            .PreserveFormatting = True
            .RefreshOnFileOpen = False
            .RefreshStyle = xlInsertDeleteCells
            .SavePassword = False
            .SaveData = True
            .AdjustColumnWidth = False
            .RefreshPeriod = 0
            .TextFilePromptOnRefresh = False
            .TextFilePlatform = 437
            .TextFileStartRow = 1
            .TextFileParseType = xlDelimited
            .TextFileTextQualifier = xlTextQualifierDoubleQuote
            .TextFileConsecutiveDelimiter = False
            .TextFileTabDelimiter = True
            .TextFileSemicolonDelimiter = False
            .TextFileCommaDelimiter = False
            .TextFileSpaceDelimiter = False
            .TextFileColumnDataTypes = Array(1, 1, 1, 1, 1, 1, 1)
            .TextFileTrailingMinusNumbers = True
            .Refresh BackgroundQuery:=False
        End With
        
        LoadTxtFile = rngDest.Value   'the acquisition ID
        
End Function

Open in new window

DCUnited

ASKER

It doesn't like the Set wbActive = Workbooks.Open(Filename:=stPath & fl)
Since that line is opening the excel template file, shouldn't it be stTemp & not fl?

DCUnited

ASKER

I was able to get this to work, but it tries to use the same text file and not the next one.
Keeps getting stuck on r99997_1_1.txt and not moving to r99997_1_2.txt & so on.

Dim stPath As String
Dim stTemp As String
Dim stText As String
Dim stFile As String
Dim wbActive As Workbook, wsTemplate As Worksheet
Dim wsActive As Worksheet

stPath = "H:\Hermes\"
stText = "r99997_1_*.txt"
stTemp = "Template Report ACQ SPOC Call Result.xlsx"

Set wbActive = Workbooks.Open(Filename:=stPath & "Templates\" & stTemp)
Set wsTemplate = wbActive.ActiveSheet
stFile = Dir$(stPath & stText)

Do While stFile <> ""

wsTemplate.Copy Before:=wsTemplate
Set wsActive = wbActive.ActiveSheet ' the new sheet
aqId = LoadTxtFile(wsActive, stPath & stFile)
wsActive.Name = aqId

Loop

End Sub

Function LoadTxtFile(wsTarget As Worksheet, txtFilename As String) As String

'Workbooks.Open Filename:=stPath & "Templates\" & stTemp
'With ActiveSheet.QueryTables.Add(Connection:="TEXT;H:\" & stText, Destination:=Range("$A$7"))
Dim rngDest As Range
Set rngDest = Range("$A$7")
With wsTarget.QueryTables.Add(Connection:="TEXT;" & txtFilename, Destination:=rngDest)
.Name = stText
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = False
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
.TextFilePlatform = 437
.TextFileStartRow = 1
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = False
.TextFileTabDelimiter = True
.TextFileSemicolonDelimiter = False
.TextFileCommaDelimiter = False
.TextFileSpaceDelimiter = False
.TextFileColumnDataTypes = Array(1, 1, 1, 1, 1, 1, 1)
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery = False
End With

LoadTxtFile = rngDest.Value 'the acquisition ID

ASKER CERTIFIED SOLUTION

Robberbaron (robr)

membership

This solution is only available to members.

To access this solution, you must be a member of Experts Exchange.

Start Free Trial

DCUnited

ASKER

I usually do embed my code or upload them. Not sure why I didn't this time. That 1 little line made all the difference. Thank you so much.