Работа с файлом через макросы

[Bridges Specialist]

День добрый, уважаемые форумчане!

Суть вопроса такова, имеется .txt файл, его нужно открыть в exel указав путь к нему. Далее его необходимо отредактировать так, чтобы все текстовые и пустые строки были удалены. А данные из столбца в который все вставилось расформировались в отдельные. Так же необходимо чтобы строки с одинаковыми значениями в стоблцах B,C,D были удалены(одна из двух осталась). Пример прикреплен в архиве: txt файл - исходный; на листе 1 в exel показано, что происходит при вставке, на листе 2, то что необходимо получить.

Спасибо!
P.S.: пытался найти данные макросы по отдельности чтобы слиять их в один, но безуспешно.

[Bridges Specialist]

Причем кол-во строк может быть больше, чем в приложенном примере

[mchip]

Самое простое - записать макрос. Нажать на кнопочку записи макроса - выполнить действия - и посмотреть макрос.
Вот что у меня получилось:

Sub Макрос1()
'
' Макрос1 Макрос
'

'
    Range("F3").Select
    With ActiveSheet.QueryTables.Add(Connection:= _
        "TEXT;D:\Users\Maxim\Downloads\1.txt", Destination:=Range("$H$4"))
        .CommandType = 0
        .Name = "1_1"
        .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 = 7
        .TextFileParseType = xlFixedWidth
        .TextFileTextQualifier = xlTextQualifierDoubleQuote
        .TextFileConsecutiveDelimiter = False
        .TextFileTabDelimiter = True
        .TextFileSemicolonDelimiter = False
        .TextFileCommaDelimiter = False
        .TextFileSpaceDelimiter = False
        .TextFileColumnDataTypes = Array(1, 1, 1, 1)
        .TextFileFixedColumnWidths = Array(7, 11, 10)
        .TextFileTrailingMinusNumbers = True
        .Refresh BackgroundQuery:=False
    End With
End Sub

[mchip]

И ему без разницы сколько строк в файле!

[IgorGO]

положите в программный модуль, выполните этот

Sub TxtRasKolbas()
  Dim fn, rg As Range, rgD As Range
  fn = Application.GetOpenFilename("Txt files, *.txt", 1, "Укажите файл", MultiSelect:=False)
  If fn = False Then Exit Sub
  Workbooks.Open (fn)
  ActiveSheet.UsedRange.Offset(, 1).FormulaR1C1 = "=trim(rc1)"
  ActiveSheet.UsedRange.Copy: Cells(1, 1).PasteSpecial Paste:=xlPasteValues
  Columns(2).TextToColumns Cells(1, 2), DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=True, _
    Semicolon:=False, Comma:=False, Space:=True, Other:=False, FieldInfo:=Array(1, 1), TrailingMinusNumbers:=True
  For Each rg In Intersect(ActiveSheet.UsedRange, Columns(2)).Cells
    If IsEmpty(rg) Or (Not IsNumeric(rg)) Then If rgD Is Nothing Then Set rgD = rg Else Set rgD = Union(rgD, rg)
  Next
  Columns(1).Delete:  If Not rgD Is Nothing Then rgD.EntireRow.Delete
End Sub

[Bridges Specialist]

Сообщение от IgorGO

положите в программный модуль, выполните этот

Sub TxtRasKolbas()
  Dim fn, rg As Range, rgD As Range
  fn = Application.GetOpenFilename("Txt files, *.txt", 1, "Укажите файл", MultiSelect:=False)
  If fn = False Then Exit Sub
  Workbooks.Open (fn)
  ActiveSheet.UsedRange.Offset(, 1).FormulaR1C1 = "=trim(rc1)"
  ActiveSheet.UsedRange.Copy: Cells(1, 1).PasteSpecial Paste:=xlPasteValues
  Columns(2).TextToColumns Cells(1, 2), DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=True, _
    Semicolon:=False, Comma:=False, Space:=True, Other:=False, FieldInfo:=Array(1, 1), TrailingMinusNumbers:=True
  For Each rg In Intersect(ActiveSheet.UsedRange, Columns(2)).Cells
    If IsEmpty(rg) Or (Not IsNumeric(rg)) Then If rgD Is Nothing Then Set rgD = rg Else Set rgD = Union(rgD, rg)
  Next
  Columns(1).Delete:  If Not rgD Is Nothing Then rgD.EntireRow.Delete
End Sub

Спасибо большое, и ещё вопрос, как удалить абсолютно все строки в которых совпадает 3 столбец?

[Hugo121]

А почему в примере не удалены "абсолютно все строки в которых совпадает 3 столбец?"
Или нужно то, что делает стандартное "удалить дубликаты"?

[IgorGO]

в начале:

необходимо чтобы строки с одинаковыми значениями в стоблцах B,C,D были удалены(одна из двух осталась)

потом:

как удалить абсолютно все строки в которых совпадает 3 столбец?

я благополучно пропустил, что нужно было удалить дубли
а теперь вопрос:
что же реально удалять?

[Bridges Specialist]

Да, согласен, неясно выяснился и возможно в примере не сделал данную вещь. Чтобы было яснее:
В третьем столбце С-указано расстояние. нужно чтобы все строки в которых одно и тоже значение расстояния (столбец C) были так же удалены.

[IgorGO]

Sub TxtRasKolbas()
  Dim fn, rg As Range, rgD As Range, r As Long
  fn = Application.GetOpenFilename("Txt files, *.txt", 1, "Укажите файл", MultiSelect:=False)
  If fn = False Then Exit Sub
  Workbooks.Open (fn)
  ActiveSheet.UsedRange.Offset(, 1).FormulaR1C1 = "=trim(rc1)"
  ActiveSheet.UsedRange.Copy: Cells(1, 1).PasteSpecial Paste:=xlPasteValues
  Columns(2).TextToColumns Cells(1, 2), DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=True, _
    Semicolon:=False, Comma:=False, Space:=True, Other:=False, FieldInfo:=Array(1, 1), TrailingMinusNumbers:=True
  For Each rg In Intersect(ActiveSheet.UsedRange, Columns(2)).Cells
    If IsEmpty(rg) Or (Not IsNumeric(rg)) Then If rgD Is Nothing Then Set rgD = rg Else Set rgD = Union(rgD, rg)
  Next
  Columns(1).Delete:  If Not rgD Is Nothing Then rgD.EntireRow.Delete: r = 1
  Do While Not IsEmpty(Cells(r, 3))
    If WorksheetFunction.CountIf(Columns(3), Cells(r, 3)) > 1 Then Rows(r).Delete Else r = r + 1
  Loop
End Sub