Sub macro1()
Application.ScreenUpdating = False
Sheets("Info").Activate
Range("1:4").EntireRow.Delete
Range("N1") = "Number"
Idx = 1
lastRow = Range("A" & Rows.Count).End(xlUp).Row
rwIdx = 2
AreaIsOn = True
Do While rwIdx <= lastRow
If Cells(rwIdx, 1) = "No." Then
AreaIsOn = True
Cells(rwIdx, 1).EntireRow.Delete
Idx = Idx + 1
Range("N" & rwIdx).Value = Idx
rwIdx = rwIdx + 1
ElseIf AreaIsOn = True And Cells(rwIdx, 1) = "" Then
AreaIsOn = False
Cells(rwIdx, 1).EntireRow.Delete
Debug.Print Cells(rwIdx, 1).End(xlDown).Row
ElseIf AreaIsOn = False And (Cells(rwIdx + 1, 1) <> "" Or Cells(rwIdx + 2, 1) <> "" Or Cells(rwIdx + 3, 1) <> "") Then
Cells(rwIdx, 1).EntireRow.Delete
lastRow = Range("A" & Rows.Count).End(xlUp).Row
Else
Range("N" & rwIdx).Value = Idx
rwIdx = rwIdx + 1
End If
Loop
Range("N1").End(xlDown).ClearContents
Range("A1").Activate
Application.ScreenUpdating = True
End Sub
Sub macro1()
Application.ScreenUpdating = False
On Error Resume Next
Set ResultSht = Sheets("Result")
On Error GoTo 0
If Not (IsEmpty(ResultSht)) Then
Application.DisplayAlerts = False
Sheets("Result").Delete
Application.DisplayAlerts = True
End If
ActiveWorkbook.Worksheets("Info").Copy After:=Sheets(Sheets.Count)
Set ResultSht = Sheets(Sheets.Count)
ResultSht.Name = "Result"
Range("1:4").EntireRow.Delete
Range("N1") = "Number"
Idx = 1
lastRow = Range("A" & Rows.Count).End(xlUp).Row
rwIdx = 2
AreaIsOn = True
Do While rwIdx <= lastRow
If Cells(rwIdx, 1) = "No." Then
AreaIsOn = True
Cells(rwIdx, 1).EntireRow.Delete
Idx = Idx + 1
Range("N" & rwIdx).Value = Idx
rwIdx = rwIdx + 1
ElseIf AreaIsOn = True And Cells(rwIdx, 1) = "" Then
AreaIsOn = False
Cells(rwIdx, 1).EntireRow.Delete
ElseIf AreaIsOn = False And (Cells(rwIdx + 1, 1) <> "" Or Cells(rwIdx + 2, 1) <> "" Or Cells(rwIdx + 3, 1) <> "") Then
Cells(rwIdx, 1).EntireRow.Delete
lastRow = Range("A" & Rows.Count).End(xlUp).Row
Else
Range("N" & rwIdx).Value = Idx
rwIdx = rwIdx + 1
End If
Loop
Range("N1").End(xlDown).ClearContents
Range("A1").Activate
Application.ScreenUpdating = True
End Sub
Regards
Sub macro1()
Application.ScreenUpdating = False
On Error Resume Next
Set ResultSht = Sheets("Result")
On Error GoTo 0
If Not (IsEmpty(ResultSht)) Then
Application.DisplayAlerts = False
Sheets("Result").Delete
Application.DisplayAlerts = True
End If
ActiveWorkbook.Worksheets("Info").Copy After:=Sheets(Sheets.Count)
Set ResultSht = Sheets(Sheets.Count)
ResultSht.Name = "Result"
Cells.NumberFormat = "General"
Range("1:4").EntireRow.Delete
Range("N1") = "Number"
Range("O1") = "Total"
Idx = 1
lastRow = Range("A" & Rows.Count).End(xlUp).Row
rwIdx = 2
AreaIsOn = True
Do While rwIdx <= lastRow
If Cells(rwIdx, 1) = "No." Then
AreaIsOn = True
Cells(rwIdx, 1).EntireRow.Delete
Idx = Idx + 1
Range("N" & rwIdx).Value = Idx
Range("O" & rwIdx).Formula = "=(J" & rwIdx & "+L" & rwIdx & ")/2"
rwIdx = rwIdx + 1
ElseIf AreaIsOn = True And Cells(rwIdx, 1) = "" Then
AreaIsOn = False
Cells(rwIdx, 1).EntireRow.Delete
ElseIf AreaIsOn = False And (Cells(rwIdx + 1, 1) <> "" Or Cells(rwIdx + 2, 1) <> "" Or Cells(rwIdx + 3, 1) <> "") Then
Cells(rwIdx, 1).EntireRow.Delete
lastRow = Range("A" & Rows.Count).End(xlUp).Row
Else
Range("N" & rwIdx).Value = Idx
Range("O" & rwIdx).Formula = "=(J" & rwIdx & "+L" & rwIdx & ")/2"
rwIdx = rwIdx + 1
End If
Loop
Range("N1").End(xlDown).ClearContents
Range("A1").Activate
Application.ScreenUpdating = True
End Sub
Regards
pls try
Open in new window
Regards