将多个文本文件导入工作簿，其中工作表名称与文本文件名称匹配 [英] 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.

点击导入文本文件"按钮后，VBA代码:

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

1. 检查现有工作簿中与文本文件名称匹配的工作表名称.如果存在，请清除工作表的内容并将数据复制到工作表中.

2. 例如，如果我的文本文件名类似于" Data_REQ1 "，" Data_REQ2 "等等，直到 Data_REQ30 ，代码应检查以Data_REQ1开头的工作表，如果存在则清除内容，将数据从文本文件Data_REQ1复制到工作表Data_REQ1，以此类推. 伪代码:

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

这是我的完整代码

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

以前的版本:

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

当前版本

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.

推荐答案

考虑使用

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

这篇关于将多个文本文件导入工作簿，其中工作表名称与文本文件名称匹配的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！