Solved

Copy text files into separate worksheets in Excel

Posted on 2014-07-22
5
528 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

How your wiki can always stay up-to-date

Quip doubles as a “living” wiki and a project management tool that evolves with your organization. As you finish projects in Quip, the work remains, easily accessible to all team members, new and old.
- Increase transparency
- Onboard new hires faster
- Access from mobile/offline

Join & Write a Comment

A short article about problems I had with the new location API and permissions in Marshmallow
Although it can be difficult to imagine, someday your child will have a career of his or her own. He or she will likely start a family, buy a home and start having their own children. So, while being a kid is still extremely important, it’s also …
This Micro Tutorial demonstrate the bugs in Microsoft Excel for Mac with Pivot Charts.
This Micro Tutorial will demonstrate the scrolling table in Microsoft Excel using the INDEX function.

757 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

Need Help in Real-Time?

Connect with top rated Experts

19 Experts available now in Live!

Get 1:1 Help Now