Excel VBA：获取数据比实际数据少一

Question

我正在根据我的要求定制下面的代码，代码工作正常，唯一的问题是它不写最后一行。如果我导入 10 个文本文件，它会从 9 张表中复制值并粘贴到 Theta 表中，最后一张表数据被遗漏。我无法弄清楚它在哪里丢失。需要帮助

`Sub CombineFiles()
Dim xFilesToOpen As Variant
Dim I As Integer
Dim xWb As Workbook
Dim xTempWb As Workbook
Dim xDelimiter As String
Dim xScreen As Boolean
Dim StartTime As Double
Dim MinutesElapsed As String

StartTime = Timer

Application.DisplayAlerts = False

' Extracting PDF to Text using command line
Application.Run "convert.xlsm!PDFExtract"

On Error GoTo ErrHandler
xScreen = Application.ScreenUpdating
Application.ScreenUpdating = False

'Opening a Theta sheet where I want to paste the data
Workbooks.Open Filename:="C:\Backup\PO\Theta.xlsb"

Sheets("Rough").Select
Range("A1").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.ClearContents
Range("A1").Select

'Importing Text Files into Excel
xDelimiter = "|"
xFilesToOpen = Application.GetOpenFilename("Text Files (*.txt), *.txt", , "PO Extraction", , True)
If TypeName(xFilesToOpen) = "Boolean" Then
    MsgBox "No files were selected", , "PO Extraction"
    GoTo ExitHandler
End If
I = 1
Set xTempWb = Workbooks.Open(xFilesToOpen(I))
xTempWb.Sheets(1).Copy
Set xWb = Application.ActiveWorkbook
xTempWb.Close False
xWb.Worksheets(I).Columns("A:A").TextToColumns _
  Destination:=Range("A1"), DataType:=xlDelimited, _
  TextQualifier:=xlDoubleQuote, _
  ConsecutiveDelimiter:=False, _
  Tab:=False, Semicolon:=False, _
  Comma:=False, Space:=False, _
  Other:=True, OtherChar:="|"
Do While I < UBound(xFilesToOpen)
    I = I + 1
    Set xTempWb = Workbooks.Open(xFilesToOpen(I))
    With xWb
        xTempWb.Sheets(1).Move after:=.Sheets(.Sheets.Count)
        .Worksheets(I).Columns("A:A").TextToColumns _
          Destination:=Range("A1"), DataType:=xlDelimited, _
          TextQualifier:=xlDoubleQuote, _
          ConsecutiveDelimiter:=False, _
          Tab:=False, Semicolon:=False, _
          Comma:=False, Space:=False, _
          Other:=True, OtherChar:=xDelimiter
    End With

    'Replace unwanted lines into blanks
    Application.Run "Convert.xlsm!ReplaceText"

    'Removing Blank Rows after replace
    Range("A1:A10000").SpecialCells(xlCellTypeBlanks).EntireRow.Delete

    'Copying a concatenate formula from a cell to a imported worksheet
    Windows("convert.xlsm").Activate
    Sheets("Sheet2").Select
    Range("B1").Select
    Selection.Copy


    Windows("Book1").Activate
    Range("B1").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    Selection.Copy

    'Copying data from Book1, active imported text file sheet to Theta sheet
    Windows("Theta.xlsb").Activate
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False

    'Pasted data have lot of unwanted space and chacters, replacing them delimiter
    Application.Run "Convert.xlsm!SelectionReplace"
    ActiveCell.Offset(1, 0).Select
    ActiveWorkbook.Save

Loop

MinutesElapsed = Format((Timer - StartTime) / 86400, "hh:mm:ss")
'MsgBox ("Finished")
MsgBox "This code ran successfully in " & MinutesElapsed & " minutes", vbInformation
ExitHandler:
Application.ScreenUpdating = xScreen
Set xWb = Nothing
Set xTempWb = Nothing
Exit Sub
ErrHandler:
MsgBox Err.Description, , "PO Extraction"
Resume ExitHandler
End Sub`

Answer 1

改变

Do While I < UBound(xFilesToOpen)

到

Do While I <= UBound(xFilesToOpen)

目前，您没有执行该步骤的最后一个循环 :)