Solved

Copy text files into separate worksheets in Excel

Posted on 2014-07-22
5
531 Views
Last Modified: 2014-07-24
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
0
Comment
Question by:DCUnited
  • 3
  • 2
5 Comments
 
LVL 32

Expert Comment

by:Robberbaron (robr)
ID: 40216209
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

0
 

Author Comment

by:DCUnited
ID: 40216522
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?
0
 

Author Comment

by:DCUnited
ID: 40216636
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
0
 
LVL 32

Accepted Solution

by:
Robberbaron (robr) earned 500 total points
ID: 40216670
true on both counts...

you also should post code as an embedded  'code snippet'   use the button </>

Set wbActive = Workbooks.Open(Filename:=stPath & "Templates\" & stTemp)
Set wsTemplate = wbActive.ActiveSheet    '<<< if known , change to wbActive.Sheets("template") or similar.
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
        stFile = Dir$      '<<<< find next matching file 
    Loop

Open in new window

0
 

Author Closing Comment

by:DCUnited
ID: 40216737
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.
0

Featured Post

3 Use Cases for Connected Systems

Our Dev teams are like yours. They’re continually cranking out code for new features/bugs fixes, testing, deploying, testing some more, responding to production monitoring events and more. It’s complex. So, we thought you’d like to see what’s working for us.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

A short article about problems I had with the new location API and permissions in Marshmallow
This article will guide you to convert a grid from a picture into Excel format using Microsoft OneNote and no other 3rd party application.
With the power of JIRA, there's an unlimited number of ways you can customize it, use it and benefit from it. With that in mind, there's bound to be things that I wasn't able to cover in this course. With this summary we'll look at some places to go…
Although Jacob Bernoulli (1654-1705) has been credited as the creator of "Binomial Distribution Table", Gottfried Leibniz (1646-1716) did his dissertation on the subject in 1666; Leibniz you may recall is the co-inventor of "Calculus" and beat Isaac…

770 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question