Sub rm()For i = 1 To Sheet1.UsedRange.Rows.CountIf Sheet1.Cells(i, 9) <> "" ThenFor j = 1 To 10Sheet2.Cells(i, j) = Sheet1.Cells(i, j)NextEnd IfIf Sheet1.Cells(i + 1, 9) = "" ThenIf Sheet1.Cells(i, 9) <> "" Then k = iSheet2.Cells(k, 10).Value = Sheet2.Cells(k, 10).Value & Chr(10) & Sheet1.Cells(i + 1, 10).ValueEnd IfNextApplication.ScreenUpdating = FalseFor i = Sheet2.UsedRange.Rows.Count To 1 Step -1If Sheet2.Cells(i, 9) = "" Then Rows(i).EntireRow.DeleteNext iApplication.ScreenUpdating = TrueEnd Sub