将表从txt文件传输到excel的VBA代码

Question

我正在编写一个代码来读取txt文件中的表，并将第一个列导出到excel表中。但由于某些原因，我遇到了一些错误。它继续复制我不想要的第一行并错过表格中的最后一行。

有关图片，请参阅错误1和错误2。错误1显示了txt文件和我想要的表格＆＃34; copy＆＃34;。错误2显示了如何导入到Excel中。你可以看到它错过了＆＃34; 9.5＆＃34;行和复制＆＃34;名称和开发＆＃34;而不是

  Sub AddNewData()
If ActiveSheet.Name <> "EntryPage" Then GoTo EnterData
Pump_Tag_ID = InputBox("Please Type Pump Tag:", "Enter Pump Tag")
If Pump_Tag_ID = "" Then End
Worksheets("ImplementationSheet").Range("H1") = Pump_Tag_ID
TotalSheets = ThisWorkbook.Worksheets.Count
For Each Sheet In Worksheets
        If Pump_Tag_ID = Sheet.Name Then
            Sheets(Pump_Tag_ID).Activate
        Else
        i = i + 1
        End If
    Next Sheet
    If i = TotalSheets Then
        Dim Ans As Integer
            Ans = MsgBox("The Pump Tag # does not exist. Please add it.", vbOKCancel + vbInformation)
        Select Case Ans
            Case vbOkay: GoTo Form_AddNewTag
            Case vbCancel: Exit Sub
        End Select
Form_AddNewTag:
        AddNewTag.Show
    End If
If cContinue = "No" Then End
'Get The Data
EnterData:
CurrentSheet = ActiveSheet.Name
'Application.ScreenUpdating = False



Dim myObj As Object
Dim myDirString As String

Set myObj = Application.FileDialog(msoFileDialogFilePicker)

With myObj
    .InitialFileName = "C:\Users\" & Environ$("Username") & ".domain\Documents"
    .Filters.Clear
    .Filters.Add "Text Files", "*.txt", 1
    If .Show = False Then MsgBox "Please select TXT file.", vbExclamation: Exit Sub
    myDirString = .SelectedItems(1)
End With
Sheets.Add
With ActiveSheet.QueryTables.Add(Connection:= _
    "TEXT;" & myDirString, Destination:=Range("$A$1"))
     .Name = "TxtImport"
    .FieldNames = True
    .RowNumbers = False
    .FillAdjacentFormulas = False
    .PreserveFormatting = True
    .RefreshOnFileOpen = False
    .RefreshStyle = xlInsertDeleteCells
    .SavePassword = False
    .SaveData = True
    .AdjustColumnWidth = True
    .RefreshPeriod = 0
    .TextFilePromptOnRefresh = False
    .TextFilePlatform = 1252
    .TextFileStartRow = 1
    .TextFileParseType = xlDelimited
    .TextFileTextQualifier = xlTextQualifierDoubleQuote
    .TextFileConsecutiveDelimiter = False
    .TextFileTabDelimiter = True
    .TextFileSemicolonDelimiter = False
    .TextFileCommaDelimiter = False
    .TextFileSpaceDelimiter = True
    .TextFileColumnDataTypes = Array(2, 1, 1, 1, 1)
    .TextFileTrailingMinusNumbers = True
    .Refresh BackgroundQuery:=False
End With

'rest of the formatting codes here
Range("B1") = "=MATCH(""CSYS:"",A:A,0)"
dDate = Range("C2")
DataStart = Range("B1") + 1
Range(Cells(DataStart, 1), Cells(DataStart + 24, 2)).Copy Worksheets("ImplementationSheet").Range("A1:B25")
Application.DisplayAlerts = False
ActiveSheet.Delete
Application.DisplayAlerts = True


    Worksheets("ImplementationSheet").Activate
    Worksheets("ImplementationSheet").Range("A1:B25").Select
    ActiveWorkbook.Worksheets("ImplementationSheet").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("ImplementationSheet").Sort.SortFields.Add Key:= _
        Worksheets("ImplementationSheet").Range("A2:A25"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortTextAsNumbers
    With ActiveWorkbook.Worksheets("ImplementationSheet").Sort
        .SetRange Worksheets("ImplementationSheet").Range("A2:B25")
        .Header = xlNo
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    Worksheets("ImplementationSheet").Range("A1").Select

Worksheets("ImplementationSheet").Range("F1") = dDate
Worksheets(CurrentSheet).Activate
Application.ScreenUpdating = True
NewOrExistingVolute.Show

End Sub

错误1

错误2

Answer 1

试试这个，如果你得到不同的结果，请告诉我：

DataStart = Range("B1").Row + 1