VBA - 纯文本导入更改

Question

我们有一个关键任务电子表格，它从设计程序中导入大量平面文本，然后将其导入此电子表格。

我们最近更新了设计软件，我们每年更新一次，并且在我在这里的 12 年中一直这样做。 今年，他们对一个文件进行了更改，将一列文本的 header 放在了不同的位置。 现在，我们的程序将无法正确导入它。 这是PART专栏...

旧文本文件：

新建文本文件...

正如您所看到的，他们将 PART 移到了左下角。

不是 VBA 的专家，我正在努力寻找我需要修改代码以正确引入它的确切位置。

这是 VBA 代码的一部分，我确实认为在其中进行了选择，但代码中没有指定 PART ……也许它是数组的一部分？ 该文件称为 CZE_DET.OUT。

    Sub IMPORT_CZEOUT()
    Dim aryJobs() As String
    Dim strComb As String
    Dim strDir As String
    Dim i As Integer
    Dim j As Integer
    Dim k As Integer

    Sheets("CEE ORDER").Visible = True
    Sheets("CZE_DET").Visible = True
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False

    Sheets("CEE ORDER").Select
    For i = 1 To colAllBuildings.Count
        strDir = Dir$(colAllBuildings.Item(i) & "\CZE_DET.OUT")
        If strDir <> "" Then
            Workbooks.OpenText Filename:=colAllBuildings.Item(i) & "\CZE_DET.OUT", Origin:=xlWindows, _
                               StartRow:=7, DataType:=xlFixedWidth, _
                               FieldInfo:=Array(Array(0, 9), Array(5, 1), Array(9, 9), Array(10, 1), _
                               Array(13, 9), Array(14, 1), Array(15, 9), Array(16, 1), Array(18, 1), _
                               Array(28, 9), Array(35, 9), Array(47, 9), Array(54, 1), Array(57, 1), _
                               Array(62, 1), Array(67, 1), Array(72, 1))
            Range("A1:L" & CStr(Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row)).Select
            Selection.Copy
            Windows(strShipperName).Activate ' This line does not work, for NO reason!
'            Windows(1).ActivatePrevious
            Sheets("CZE_DET").Select
            Range("A1").Select
            If Range("A1").Value <> "" Then
                ActiveSheet.Range("A65536").End(xlUp).Select
                ActiveCell.Offset(1, 0).Select
            End If
            Selection.PasteSpecial Paste:=xlValues
            Selection.Sort Key1:=Range("A12"), Order1:=xlAscending, Orientation:=xlTopToBottom
            Windows("CZE_DET.OUT").Activate
            ActiveWindow.Close
        End If
    Next

我会发布电子表格，但它通过 a.network 共享通过 XLA 文件附加了 VBA。 XLA 文件受到保护，我似乎无法重命名它并删除密码以发送链接。

我在这里发布了整个子程序，因为我只发布了我认为问题所在的地方： https://pinnaclestructures365-my.sharepoint.com/:f:/g/personal/bwolters_pinnaclestructures_com/EpGrxtGx4_BCgL4nl3QDZxcBalaRSL52pI0k8Oyh2k?

有什么建议么？

Answer 1

这是一个重新设计的示例，说明如何使您的引用更加明确。

Sub IMPORT_CZEOUT()
    Dim aryJobs() As String
    Dim strComb As String
    Dim strDir As String
    Dim i As Integer, cDest As Range
    Dim j As Integer, fName As String, rngData As Range, lRow As Long
    Dim k As Integer, wb As Workbook, wbSrc As Workbook, wsSrc As Worksheet

    Set wb = Workbooks(strShipperName) 'The wb where data is to be collected
                                       'Include the file extension!
    wb.Sheets("CEE ORDER").Visible = True
    wb.Sheets("CZE_DET").Visible = True
    
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False

    For i = 1 To colAllBuildings.Count
        fName = colAllBuildings.Item(i) & "\CZE_DET.OUT"
        If Len(Dir(fName)) > 0 Then
            Workbooks.OpenText Filename:=fName, Origin:=xlWindows, _
                               StartRow:=7, DataType:=xlFixedWidth, _
                               FieldInfo:=Array(Array(0, 9), Array(5, 1), Array(9, 9), Array(10, 1), _
                               Array(13, 9), Array(14, 1), Array(15, 9), Array(16, 1), Array(18, 1), _
                               Array(28, 9), Array(35, 9), Array(47, 9), Array(54, 1), Array(57, 1), _
                               Array(62, 1), Array(67, 1), Array(72, 1))
            Set wbSrc = ActiveWorkbook      'source data workbook
            Set wsSrc = wbSrc.Worksheets(1) 'source data sheet
            lRow = wsSrc.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
            Set rngData = wsSrc.Range("A1:L" & lRow) 'all source data
            With wb.Worksheets("CZE_DET") 'EDIT
                Set cDest = .Cells(.Rows.Count, "A").End(xlUp)
            End With
            If Len(cDest.Value) > 0 Then Set cDest = cDest.Offset(1)
            cDest.Resize(rngData.Rows.Count, rngData.Columns.Count).Value = rngData.Value
            'not sure about this line....
            Selection.Sort Key1:=Range("A12"), Order1:=xlAscending, Orientation:=xlTopToBottom
            wbSrc.Close savechanges:=False 'close the source file
        End If
    Next
    
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub

编辑 - 正如评论中指出的那样，其中一个文件的长度增加了 1 个字符，因此需要更新FieldInfo参数：

Workbooks.OpenText Filename:=fName, Origin:=xlWindows, _
                           StartRow:=7, DataType:=xlFixedWidth, _
                           FieldInfo:=Array(Array(0, 9), Array(5, 1), Array(9, 9), Array(10, 1), _
                           Array(13, 9), Array(14, 1), Array(15, 9), Array(16, 1), Array(18, 1), _
                           Array(28, 9), Array(35, 9), Array(47, 9), Array(55, 1), Array(58, 1), _
                           Array(63, 1), Array(68, 1), Array(73, 1))

Answer 2

可以简化 open 语句，因为跳过的字段 (type=9) 是空白，并且值在导入时被修剪。

Workbooks.OpenText Filename:=s, Origin:=xlWindows, _
          StartRow:=7, DataType:=xlFixedWidth, _
          FieldInfo:=Array(Array(0, 9), Array(4, 1), Array(18, 1), Array(27, 1), _
                           Array(35, 1), Array(54, 1), Array(58, 1),  _ 
                           Array(63, 1), Array(68, 1), Array(73, 1))

使用此文本文件进行测试

line 1
line 2
line 3
line 4
line 5
line 6
ish description   part     punch   comment            qnt feet inch 16th mark
--- ------------- -------- ------- ------------------ --- ---- ---- ---- ------
xxx  8.0x3.5 c 12 8x35c12  psu-psu see drawing ec-1    28  16    8    3  ec-1
xxx  8.0x3.5 c 12 8x35c12  psu-psu see drawing ec-1    28  16    8    3  ec-1
xxx  8.0x3.5 c 12 8x35c12  psu-psu see drawing ec-1    28  16    8    3  ec-1
a-z a-----------z a----- z a-----z a----------------z a-z a--z a--z a--z a----z