Sub 整理() Dim r As Long, c As Long r = Sheet1.UsedRange.Rows.Count c = Sheet1.UsedRange.Columns.Count Dim arr ReDim arr(1 To 10000) n = 1 For j = 3 To c For i = 1 To r If Cells(i, j) <> "" Then arr(n) = Cells(i, j) n = n + 1 End If Next Next Range("a1").Resize(n - 1, 1) = WorksheetFunction.Transpose(arr) End Sub