Попытка l oop IF (функция MID на листе - PullRequest
Новая
       58

Попытка l oop IF (функция MID на листе

0 голосов
/ 04 марта 2020

У меня есть лист с именем Data, который я копирую и вставляю из файла фиксированной ширины .txt. Это примерно 100 000+ строк данных, которые мне нужны для l oop через каждую строку и извлечения данных, и, если они соответствуют критериям, результаты отображаются на листе с именем AVS. Я уверен, что упускаю что-то простое, но для моей жизни это даст мне результат только с первой строки и только потом остановится.

Вот что у меня так далеко: 

Sub AVSRev()
    Dim ws As Worksheet, thisRng As Range, ws1 As Worksheet
    Dim lastrow As Long

    Set ws1 = ThisWorkbook.Sheets("Data")
    Set ws = ThisWorkbook.Sheets("AVS")
    Set thisRng = ws.Range("A1")

    Application.ScreenUpdating = False

    With ws
        lastrow = .Range("A" & .Rows.Count).End(xlUp).row

        If Mid(ws1.Range("A1:A" & lastrow).Value, 1, 3) = "AVS" Then
        thisRng = Mid(ws1.Range("A1:A" & lastrow).Text, 48, 4)

        End If

        On Error Resume Next
        Cells.SpecialCells(xlCellTypeFormulas, xlErrors).Clear
        Application.ScreenUpdating = True
    End With
End Sub

После нескольких дней возни с этим я переписал код, как показано ниже. Я не получаю никаких ошибок, как это было раньше, но это занимает вечность, и по окончании данных нет в списке. 

Option Explicit
Sub test123()

Dim ws As Worksheet
Dim ws1 As Worksheet

Set ws = ThisWorkbook.Worksheets("DATA")
Set ws1 = ThisWorkbook.Worksheets("AVS")
Dim lastRow, myLoop, newValue
lastRow = ws.Cells(Rows.Count, 1).End(xlUp).row
Dim AVS As Range
Application.ScreenUpdating = False


Range("A" & lastRow).ClearContents

For myLoop = 1 To lastRow

On Error Resume Next
   AVS = MID(ws.Range("A1:A" & myloop).Value, 1, 3)
   If IsError(AVS.Value) Then
    If Err.Number <> 0 Then
            Err.Clear
            On Error GoTo 0
        End If


Else
   If AVS = "AVS" Then
      'If MID(ws.Range("A1:A" & lastRow).Value, 1, 3) = "AVS" Then
         newValue = MID(ws.Range("A" & myLoop).Value, 48, 4)

    End If
End If
        ws1.Range("A" & myLoop).Value = newValue

Next

 Application.ScreenUpdating = True
End Sub

Я также перечислил ниже пример данных, которые я пытаюсь получить, на листе «Данные». Пример данных

Спасибо за помощь!

1 Ответ

0 голосов
/ 06 марта 2020

Благодаря @ScottHoltman и @Gaffi мне удалось получить свой код l oop со следующим: 

Sub AVS()

Dim ws As Worksheet
Dim ws1 As Worksheet

Set ws = ThisWorkbook.Worksheets("DATA")
Set ws1 = ThisWorkbook.Worksheets("AVS")
Dim lastRow, myLoop, newValue
lastRow = ws.Cells(Rows.Count, 1).End(xlUp).row
Application.ScreenUpdating = False


Range("A" & lastRow).ClearContents

For myLoop = 1 To lastRow

   If MID(ws.Range("A" & myLoop).Value, 1, 3) = "AVS" Then
      newValue = MID(ws.Range("A" & myLoop).Value, 48, 4)
End If

        ws1.Range("A" & myLoop).Value = newValue

Next

 Application.ScreenUpdating = True
End Sub

Это подняло еще одну проблему, которую я решу с помощью другого поста. спасибо.

...