將多個文本文件導入工作簿，其中工作表名稱與文本文件名相匹配

Question

簡介：繼續我的前一個question，最初，我的上一個代碼（藉助於Stack交換專家的幫助）可以正常工作。

問題：但下一次當我再次導入文件時（我必須每月進行一次），它會創建重複的表格。所以我想修改我的項目如下。

在點擊「導入文本文件」按鈕，VBA代碼：

1. 檢查相匹配的文本文件名中的工作表名稱的現有工作簿。如果存在，清除工作表的內容並將數據複製到工作表中。

2. 例如，如果我的文本文件名稱類似於「Data_REQ1」，「Data_REQ2」依此類推，直到Data_REQ30，代碼應該檢查開始Data_REQ1表，如果存在明確的內容，複製將來自文本文件Data_REQ1的數據導入到其他工作表的工作表Data_REQ1等。 僞代碼：

   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 

現存版本

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 

我的要求：隨着這一變化，我能清楚的內容，但不能粘貼數據。任何建議或任何比這段代碼更好的代碼將不勝感激。

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