| 
    
     |  | ▼kenkyu-sya さん: 
 アップ済みのコードと基本かわりませんが、処理効率を若干あっぷさせたものも参考までに。
 
 Sub Test2()
 Dim r As Range
 Dim a As Range
 Dim f As Range
 Dim t As Range
 
 Application.ScreenUpdating = False
 
 With Range("A1").CurrentRegion
 With .Offset(1, 1).Resize(.Rows.Count - 1, .Columns.Count - 1)
 For Each r In .Rows
 On Error Resume Next
 Set a = r.SpecialCells(xlCellTypeConstants)
 On Error GoTo 0
 If Not a Is Nothing Then
 If a.Areas.Count > 1 Then
 Set f = a.Areas(1).Cells(1)
 Set t = a.Areas(a.Areas.Count).Cells(a.Areas(a.Areas.Count).Cells.Count)
 Range(f, t).Value = f.Value
 End If
 End If
 Next
 End With
 End With
 End Sub
 
 |  |