|    | 
     ▼ayu さん: 
 
たとえば以下で試してみてください。 
どうしても、遅い!! ということなら別途の方法を考えましょう。 
 
Sub Sample() 
  Dim shF As Worksheet 
  Dim shT As Worksheet 
  Dim x As Long 
  Dim c As Range 
   
  Application.ScreenUpdating = False '処理中の画面の動きを隠す 
   
  Set shF = Workbooks.Open(ThisWorkbook.Path & "\元のブック.xlsx").Sheets("該当のシート名") 
  Set shT = ThisWorkbook.Sheets("転記先のシート名") 
   
  shT.Cells.ClearContents   '転記前にクリア 
  x = 1            '転記開始行 
   
  For Each c In shF.Range("A9:F9")  '元ブックの合計行のセルの取り出し 
    If c.Value > 0 Then       ' 0 超なら 
      shT.Cells(x, "A").Value = c.EntireColumn.Cells(2).Value   '項目名 
      shT.Cells(x, "B").Value = c.Value              '合計数 
      x = x + 1  '次の転記行 
    End If 
  Next 
   
  shF.Parent.Close False '元ブックを閉じる 
     
End Sub 
 | 
     
    
   |