Excel VBA пытается сопоставить массив с подстановочными знаками - PullRequest
Новая
       28

Excel VBA пытается сопоставить массив с подстановочными знаками

0 голосов
/ 12 сентября 2018

У меня сейчас есть код, который я использовал в прошлой жизни ... 

Dim ArrNames

ArrNames = Array("X-Axis", "Y-Axis", "Z-Axis", "Flatness", _
  "Length-X", "Length-Y", "Length-Z", "Length_X", "Length_Y", _
  "Length_Z", "Length", "Angle", "Angle-XY", "Angle-XZ", "Angle-YX", _
  "Angle-YZ", "Angle-ZX", "Angle-ZY", "Radius", "Diameter", "Flatness", _
  "Straightness", "Parallelism", "Perpendicular", "Circularity")

Sheets(2).Range("A:A").Copy Destination:=Sheets(1).Range("A:A", "C:C")

With ActiveSheet
    Lastrow = .UsedRange.Rows(.UsedRange.Rows.Count).Row
    For Lrow = Lastrow To 1 Step -1
        With .Cells(Lrow, "C")
            If IsError(Application.Match(.Value, ArrNames, 0)) Then .ClearContents
        End With
    Next Lrow
    For Lrow = Lastrow To 1 Step -1
        With .Cells(Lrow, "A")
            If Not IsError(Application.Match(.Value, ArrNames, 0)) Then .ClearContents
        End With
    Next Lrow
End With

Итак, что это делает ... он копирует столбец (столбец A) из листа № 2 и вставляет содержимое в лист № 1 в двух местах (столбец A и столбец C). Данные содержат несколько сотен строк таких строк: 

(Z): Item (126) / (X) : Item (132)
Circle:P4_EJECTOR_SIDE_OP_10_Locate
Z-axis
X-axis

Point:P8_PAD_PNT
Y-axis

Plane:P8_PAD
Flatness
Parallelism

Circle:P8_EJECTOR_SIDE_DEEP
Z-axis
X-axis

Затем я перебираю строку за строкой столбца C листа № 1, проверяя, совпадает ли содержимое ячейки с любым из значений в моем массиве. Если совпадение не найдено, я очищаю содержимое ячейки.

Затем аналогичным образом я перебираю строку за строкой столбца № 1 листа A, проверяя, совпадает ли содержимое ячейки с любым из значений в моем массиве. Тем не менее, в этом случае, если совпадение найдено, я очищаю содержимое ячейки (так что в основном это противоположно тому, что делает столбец C).

Это только часть гораздо более крупного животного, которое автоматически импортирует отдельные файлы .csv и собирает данные вместе для статистического анализа, и это работает.

Теперь я пытаюсь сделать то же самое с файлами .rtf. Файлы выглядят так ... 

(Z): Item (126) / (X) : Item (132)
Circle:P4_EJECTOR_SIDE_OP_10_Locate
Z-axis       -46.435   -46.500    -0.150    +0.150     0.065 ---+*--
X-axis      -116.836  -117.000    -0.150    +0.150     0.164 ---+-->       0.014
--------------------------------------------------------------------------------
Point:P8_PAD_PNT
Y-axis       -21.611   -21.500    -0.200    +0.200    -0.111 -*-+---
--------------------------------------------------------------------------------
Plane:P8_PAD
Flatness       0.015     0.200                                  *---
Parallelism    0.078     0.200,FA(Part_Offset_Plane)            +*--
--------------------------------------------------------------------------------
Circle:P8_EJECTOR_SIDE_DEEP
Z-axis         0.072     0.000    -0.150    +0.150     0.072 ---+*--
X-axis        -0.010     0.000    -0.150    +0.150    -0.010 ---*---

Поэтому я попытался изменить мои ArrNames, чтобы они включали в себя дикие символы, например:

ArrNames = Array ("--- *")

Но это не работает ...

Я пытаюсь удалить все "---------------------"

Вот мой точный код:

Суб тест () 

Dim Word As New Word.Application
Dim WordDoc As New Word.Document
Dim FilesToOpen
Dim x As Integer
Dim Lrow As Long
Dim Lastrow As Long
Dim ArrNames

With Application
    .ScreenUpdating = False
    .EnableEvents = False
End With

ArrNames = Array("---*")

FilesToOpen = Application.GetOpenFilename _
  (FileFilter:="RTF Files (*.rtf), *.rtf", _
  MultiSelect:=True, Title:="Files to Open")

Application.DisplayAlerts = False

x = 1

Set WordDoc = Word.Documents.Open(Filename:=FilesToOpen(x), ReadOnly:=True)
Word.Selection.WholeStory
Word.Selection.Copy

Range("A1").Select
ActiveSheet.Paste

WordDoc.Close
Word.Quit

Application.DisplayAlerts = True

With ActiveSheet
    Lastrow = .UsedRange.Rows(.UsedRange.Rows.Count).Row
    'For Lrow = Lastrow To 1 Step -1
        'With .Cells(Lrow, "A")
            'If IsError(Application.Match(.Value, ArrNames, 0)) Then .ClearContents
        'End With
    'Next Lrow
    For Lrow = Lastrow To 1 Step -1
        With .Cells(Lrow, "A")
            If Not IsError(Application.Match(.Value, ArrNames, 0)) Then .ClearContents
        End With
    Next Lrow
End With

End Sub

Как вы можете видеть, я просто скопировал часть кода из моего предыдущего кода и закомментировал ту часть, которой я сейчас не пользуюсь.

...