範囲内のループセルと各ワークシートのループ

Question

コードが次のワークシートでセルを選択しないのはなぜですか？私のコピーブックは12のワークシートを含んでいます。 Sheet.Name = ("cat","rabbit","cow","sheep"...+8)。

各シートには同じヘッダーがあります。 Col(B1:AK1)= year(1979,1980,...2014)。

貼り付けを繰り返し開いている別のフォルダにあります。 File.Name = (1979.xlsx, 1980.xlsx,..,2014.xlsx)。

各シートには12個の列があります。 Col(B1:M1)= ("cat","rabbit","cow","sheep"...+8)。

範囲内の各セルはきれいにループしますが、ワークシートはそうではありません。コードの実行が終了すると、worksheet("cat")から同じデータを持つ貼り付けブックがチェックされます。私はコーディングに熟練していないので、コードを改善できるときはいつでも助言してください。

Sub transferPict() 

Dim wsC As Integer 
Dim cell As Range 
Dim Rng As Range 
Dim j, i As Long 
Dim x As String 
Dim Folderpath 
Dim file As String  

Application.ScreenUpdating = False 
Application.EnableEvents = False 
Application.Calculation = xlCalculationManual 

wsC = ThisWorkbook.Sheets.Count 
For j = 1 To wsC 
i = j + 1 
Set Rng = Range("B1:AK1") 
For Each cell In Rng 
    x = cell.Value 
    cell.Offset(1, 0).Select 
    Range(Selection, Selection.End(xlDown)).Select 
    Selection.CopyPicture Appearance:=xlScreen, Format:=xlPicture 

    Folderpath = "F:\Sony Pendrive\Data Baru\Tahun\PasteTahun\" 
    file = Folderpath & x & ".xlsx" 
    Workbooks.Open (file) 
    ActiveWorkbook.Worksheets("sheet1").Select 
     ActiveSheet.Cells(2, i).Select 
     ActiveSheet.Paste 
     ActiveWorkbook.Close saveChanges:=True 

Next cell 
Next j 

Application.EnableEvents = True 
Application.Calculation = xlCalculationAutomatic 
Application.ScreenUpdating = True 

End Sub 

Answer 1

コピー先のワークシートを指定していないため、常に「アクティブ」シートが使用されます。

うまくいけば、このコードはあなたの問題を修正します：

Sub transferPict() 
    Dim wsC As Integer 
    Dim cell As Range 
    Dim Rng As Range 
    'Dim j, i As Long ' <--- This is equivalent to Dim j As Variant, i As Long 
    Dim j As Long, i As Long 
    Dim x As String 
    Dim Folderpath 
    Dim file As String 

    Application.ScreenUpdating = False 
    Application.EnableEvents = False 
    Application.Calculation = xlCalculationManual 

    wsC = ThisWorkbook.Sheets.Count 
    For j = 1 To wsC 
     i = j + 1 
     Set Rng = ThisWorkbook.Sheets(j).Range("B1:AK1") 
     For Each cell In Rng 
      x = cell.Value 
      ThisWorkbook.Sheets(j).Range(cell.Offset(1, 0), cell.Offset(1, 0).End(xlDown)).CopyPicture Appearance:=xlScreen, Format:=xlPicture 

      Folderpath = "F:\Sony Pendrive\Data Baru\Tahun\PasteTahun\" 
      file = Folderpath & x & ".xlsx" 
      Workbooks.Open file 
      ActiveWorkbook.Worksheets("sheet1").Cells(2, i).PasteSpecial 
      ActiveWorkbook.Close saveChanges:=True 
     Next cell 
    Next j 

    Application.EnableEvents = True 
    Application.Calculation = xlCalculationAutomatic 
    Application.ScreenUpdating = True 

End Sub