Sub lqxs() Dim Arr, i&, Sht As Worksheet, n& n = 1 For Each Sht In Sheets If Sht.Name <> "汇总" Then Arr = Sht.[b2:e2] n = n + 1 Cells(n, 1) = Sht.Name Cells(n, 2).Resize(1, 4) = Arr End If Next End Sub