Solved

Copy text files into separate worksheets in Excel

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

Is Your Active Directory as Secure as You Think?

More than 75% of all records are compromised because of the loss or theft of a privileged credential. Experts have been exploring Active Directory infrastructure to identify key threats and establish best practices for keeping data safe. Attend this month’s webinar to learn more.

Question has a verified solution.

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

Deploying a Microsoft Access application in a Citrix environment is not difficult but takes a few steps. However, Citrix system people are often of little help, as they typically know next to nothing about Access. The script provided here will take …
Some code to ensure data integrity when using macros within Excel. Also included code that helps secure your data within an Excel workbook.
This Micro Tutorial will demonstrate how to use longer labels with horizontal bar charts instead of the vertical column chart.
Excel styles will make formatting consistent and let you apply and change formatting faster. In this tutorial, you'll learn how to use Excel's built-in styles, how to modify styles, and how to create your own. You'll also learn how to use your custo…

920 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

16 Experts available now in Live!

Get 1:1 Help Now