Question

我的文件看起来像这样：

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

Answer 1

从您的第一个循环开始，我假设结构总是相同的。 Item1，空白行，Augtraggeber / 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

如何循环直到单元格为空

1 个答案: