Question

简介：继续我之前的question，最初，我之前的代码（在Stack交换专家的帮助下）运行正常。

问题：但下次再次导入文件时（我必须每月进行一次），它会创建重复的表格。所以我想修改我的项目如下。

单击“导入文本文件”按钮，VBA代码：

检查现有工作簿中是否有与文本文件名匹配的工作表名称。如果存在，请清除工作表的内容并将数据复制到工作表中。
例如，如果我的文本文件名称类似于“ Data_REQ1 ”，“ Data_REQ2 ”等等，直到 Data_REQ30 ，代码应检查以Data_REQ1开头的工作表，如果存在则清除内容，将数据从文本文件Data_REQ1复制到工作表Data_REQ1中，依此类推其他工作表。伪代码：
```
<ng-container>
```

这是我的完整代码

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

现有版本

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

我的请求：通过此更改，我可以清除内容，但不会粘贴数据。任何建议或任何代码优于此代码将不胜感激。

Answer 1

考虑使用QueryTables导入文本文件。无需复制/粘贴临时工作簿：

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

将多个文本文件导入工作簿，其中工作表名称与文本文件名匹配

1 个答案: