Как зациклить, пока ячейка не пуста - PullRequest
Новая
       10

Как зациклить, пока ячейка не пуста

0 голосов
/ 18 апреля 2019

мой файл выглядит примерно так: 

Date of Email           Body of Email
21.01.2019 07:16    xyz
21.01.2019 07:16    
21.01.2019 07:16    Auftraggeber/in
21.01.2019 07:16    
21.01.2019 07:16    xyz111
21.01.2019 07:16    
31.01.2019 07:16    abc
31.01.2019 07:16    
31.01.2019 07:16    Auftraggeber/in
31.01.2019 07:16    
31.01.2019 07:16    abc111
31.01.2019 07:16    
11.01.2019 07:16    efg
11.01.2019 07:16    
11.01.2019 07:16    Auftraggeber/in
11.01.2019 07:16    
11.01.2019 07:16    efg111
11.01.2019 07:16

формат, который я хотел бы иметь: 

Kunde   Auftraggeber/in
xyz     xyz111
abc     abc111
efg     efg111

Это мой код. Я не могу добиться того, чтобы он зациклился, пока моя ячейка файла A2 не станет пустой, так как после каждого раунда я удаляю записи с одинаковой датой. Не могли бы вы помочь? Спасибо. 

Dim x As Integer
Dim b As Integer


Workbooks("Mail2xlsxTemplate.xlsx").Activate

For x = 2 To 60
    For b = 1 To 16
        Workbooks("MailTemplate.xlsx").Activate
        Cells(x, 2).Copy
        x = x + 4
        Workbooks("Mail2xlsxTemplate.xlsx").Activate
        Cells(2, b).PasteSpecial
    Next
Next

Workbooks("MailTemplate.xlsx").Activate


Dim Firstrow As Long
Dim Lastrow As Long
Dim Lrow As Long
Dim CalcMode As Long
Dim ViewMode As Long
Dim ron As Range


With Application
    CalcMode = .Calculation
    .Calculation = xlCalculationManual
    .ScreenUpdating = False
End With

    'delete rows with same value in A column

If Not IsEmpty("A2") Then

    With ActiveSheet

        'We select the sheet so we can change the window view
        .Select

        'If you are in Page Break Preview Or Page Layout view go
        'back to normal view, we do this for speed
        ViewMode = ActiveWindow.View
        ActiveWindow.View = xlNormalView

        'Turn off Page Breaks, we do this for speed
        .DisplayPageBreaks = False
        'Set the first and last row to loop through

        Firstrow = .UsedRange.Cells(1).Row
        Lastrow = .UsedRange.Rows(.UsedRange.Rows.Count).Row

        'We loop from Lastrow to Firstrow (bottom to top)
        For Lrow = Lastrow To Firstrow Step -1

            'We check the values in the A column in this example
            With .Cells(Lrow, "A")
                If Not IsError(.Value) Then
                    'This will delete each row with the Value "ron"
                    'in Column A, case sensitive.
                    If .Value = Range("A2").Value Then .EntireRow.Delete
                 End If
            End With
        Next Lrow
    End With
 End If

ActiveWindow.View = ViewMode
With Application
    .ScreenUpdating = True
    .Calculation = CalcMode
End With

1 Ответ

0 голосов
/ 18 апреля 2019

Из вашего первого цикла я предполагаю, что структура всегда одинакова. Item1, пустая строка, Auftraggeber / in, пустая строка, «Сообщение», пустая строка (повтор) 

Sub Test()
    Dim oCurRowSource As Long
    Dim oCurRowDest As Long
    oCurRowSource = 1       ' First Row in your source
    oCurRowDest = 2         ' First Row in your destination

    While oCurRowSource < 20 ' Last row you want to check
        If Sheet1.Cells(oCurRowSource, 2) <> "" Then
            Sheet2.Cells(oCurRowDest, 1) = Sheet1.Cells(oCurRowSource, 2)
            Sheet2.Cells(oCurRowDest, 2) = Sheet1.Cells(oCurRowSource + 4, 2)

            oCurRowSource = oCurRowSource + 4
            oCurRowDest = oCurRowDest + 1
        End If
        oCurRowSource = oCurRowSource + 1
    Wend
End Sub
...