Sub ex()
Dim xD As Range, Arr()
Set xD = Sheet1.[a1].CurrentRegion
m = (xD.Rows.Count - 1) * (xD.Columns.Count - 2) + 1
ReDim Preserve Arr(1 To m, 1 To 4)
Arr(1, 1) = "科室"
Arr(1, 2) = "姓名"
Arr(1, 3) = "上休"
Arr(1, 4) = "日期"
n = 1
For r = 2 To xD.Rows.Count
For c = 3 To xD.Columns.Count
n = n + 1
Arr(n, 1) = xD(r, 1) '"科室"
Arr(n, 2) = xD(r, 2) '"姓名"
Arr(n, 3) = xD(r, c) '"上休"
Arr(n, 4) = xD(1, c) '"日期"
Next
Next
With Sheet3
.[a1].Resize(n + 1, 4) = ""
.[a1].Resize(n, 4) = Arr
End With
End Sub