Sub Macro1() Dim i, j, r, h As Integer
Dim row, note As Long
Dim wrksht As Worksheet
Dim vung, day, shtname, x, y As String
i = Sheets.Count
j = 1
r = 1
h = 1
row = 15
note = 2
Sheets.Add after:=Sheets(Sheets.Count)
Sheets(i + 1).Name = "Total"
Sheets("Total").Select
Cells(1, 1) = "Region"
For Each wrksht In ThisWorkbook.Worksheets
If (wrksht.Name <> "PS") Then
Do While (j <= i)
Do While (Sheets(j).Cells(r, 2) = "")
r = r + 1
Loop
Do While (Sheets(j).Cells(r, h) <> "")
h = h + 1
Loop
If (j > i) Then
Sheets(j).Select
x = Cells(r, 1).Address
y = Cells(r, h).Address
Range(x & ":" & y).Select
Selection.Copy
Sheets("Total").Select
day = "B" & note
Range(day).Select
Selection.PasteSpecial Paste:=xlPasteValues
note = note + 1
End If
Do While (Sheets(j).Cells(row, 3) <> "")
row = row + 1
Loop
Sheets(j).Select
x = Cells(r + 1, 1).Address
y = Cells(row - 1, h - 1).Address
Range(x & ":" & y).Select
Selection.Copy
Sheets("Total").Select
day = "B" & note
Range(day).Select
Selection.PasteSpecial Paste:=xlPasteValues
day = "A" & note
Range(day) = Sheets(j).Name
shtname = day & ":A" & note + row - (r + 1)
Range(shtname).Select
Selection.FillDown
note = note + row - r
row = 15
j = j + 1
Loop
End If
Next
Sheets("Total").Select
ActiveCell.SpecialCells(xlLastCell) = ""
Columns(3).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
Cells.Select
Cells.EntireColumn.AutoFit
Cells.EntireRow.AutoFit
Range("A1").Select
End Sub
