|
▼ゆーあ さん:
それでは、先ほどアップしたSaampleに、追加で書いてもらったコード要件を
カミして再掲。ただし、転記コードは3行しか書いてません。残りの47行は
そちらで追加して完成させてください。
で、これでもいいと思いますが、【コードを整理して短く】した Sample2 も
あわせてアップいます。コードも短くしていますが、5セル1セットの転記、
Sampleのほうではコードも5行(つまりセルに5回書き込み)あるのですが
Sample2では2行(つまりせるにへの書き込み回数は1セット2回)にしています。
まず、Sample を自分のものとして理解したのちに Sample2 に取り組んでください。
Sub Sample()
'元ブックと元シート
Dim dBK As Workbook
Dim dSh As Worksheet
'転記ブックと転記シート
Dim nBK As Workbook
Dim nSh As Worksheet
Set dBK = ThisWorkbook
Set dSh = dBK.Sheets("Sheet3")
Set nBK = Workbooks.Add(xlWBATWorksheet)
Set nSh = nBK.Sheets(1)
nSh.Name = "データ抽出"
Application.ScreenUpdating = False 'セル書き込みに伴う画面再描画の抑止(処理時間の短縮化)
nSh.Range("B6").Value = dSh.Range("A1").Value
nSh.Range("C6").Value = dSh.Range("A2").Value
nSh.Range("D6").Value = dSh.Range("A3").Value
'
'省略 ゆーあさんのほうで、コードを追加して完成させてください
'
End Sub
Sub Sample2()
Dim i As Long
Dim j As Long
'元ブックと元シート
Dim dBK As Workbook
Dim dSh As Worksheet
'転記ブックと転記シート
Dim nBK As Workbook
Dim nSh As Worksheet
Set dBK = ThisWorkbook
Set dSh = dBK.Sheets("Sheet3")
Set nBK = Workbooks.Add(xlWBATWorksheet)
Set nSh = nBK.Sheets(1)
nSh.Name = "データ抽出"
Application.ScreenUpdating = False
j = 6
For i = 1 To 46 Step 5
nSh.Cells(j, "B").Resize(, 4).Value = WorksheetFunction.Transpose(dSh.Cells(i, "A").Resize(4).Value)
nSh.Cells(j, "H").Value = dSh.Cells(i + 4, "A").Value
j = j + 5
Next
End Sub
|
|