| 
    
     |  | こんな感じかな ? 
 Sub 成績Copy1()
 Dim MyR As Range, C As Range
 
 With Sheets("選手総合成績")
 For Each C In .Range("A2", .Range("A65536").End(xlUp))
 On Error Resume Next
 Set MyR = Sheets(C.Text).Range("A2:G2")
 If Err.Number = 0 Then
 C.Offset(, 1).Resize(, 7).Value = MyR.Value
 Set MyR = Nothing
 Else
 Err.Clear
 End If
 On Error GoTo 0
 Mext
 End With
 End Sub
 
 Sub 成績Copy2()
 On Error Resume Next
 With Sheets("選手総合成績")
 .Activate
 With .Range("A2", .Range("A65536").End(xlUp)) _
 .Offset(, 1).Resize(, 7)
 .Formula = _
 "=INDIRECT(ADDRESS(2,COLUMN()-1,4,TRUE,$A2))
 .Copy
 .PasteSpecial xlPasteValues
 .SpecialCells(2, 16).ClearContents
 End With
 End With
 .Range("A1").Select
 Application.CutCopyMode = False
 End Sub
 
 |  |