Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。

  新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム  
199 / 13645 ﾂﾘｰ ←次へ　｜　前へ→
▼ 【81571】VBA データが多い場合 ゆきだるま 20/12/11(金) 14:52 質問[未読]
【81573】Re:VBA データが多い場合 ［名前なし］ 20/12/12(土) 20:15 回答[未読]
【81571】VBA データが多い場合
質問  ゆきだるま  - 20/12/11(金) 14:52 -
引用なし
パスワード
   【VBA】初心者です。
シート１にある例@のデータを
シート２のテンプレートに例Aの形にしたいです。

実際は、26項目分、テンプレートに当てはめたいデータがあります。
データは300行分くらいあります。
最終的には、番号や住所などのセルは複数行、結合させることになります。（結合までいっきにできるとなおよいです。）

Set deta()
Dim torikomi1 As Range, template1 As Range
Dim torikomi2 As Range, template2 As Range
↑このようなかたちで、26個続きます。

Dim Z Az Long, R As Long

This Workbook.Sheets("シート１").Range("A1:ZZ1000").ClearContents

Set torikomi1=Worksheets("シート１").Cells(2,1)
Set　torikomi2=Worksheets("シート１").Cells(2,2)
↑このようなかたちで、26個続きます。

Set template1 =Worksheets("シート２").Cells(3,1)
Set template2 =Worksheets("シート２").Cells(4,2)
↑このようなかたちで、26個続きます。

For Z = 0 To 2500 Set 2
　 template1.Offset(Z,0).Value = torikomi1.Offset(R,0).Value
　template2.Offset(Z,0).Value = torikomi2.Offset(R,0).Value
↑このようなかたちで、26個続きます。
R=R+1
Next Z
End Sub

26項目分なので、開くのも閉じるのも時間がかかってしまいます。
ほかに、よい方法はありますでしょうか？
よろしくお願いします。

例@
1番号 名前 ふりがな 月 日 年 住所
2 13　佐藤 さとう 3 2 北海道
3 15 伊藤 いとう 5 12 青森
4　　　　　　　　
5

例A
1 番号 ふりがな 住所
2　　　名前
3 13　さとう 北海道
4　　　佐藤
5 15　いとう 青森
6　　　伊藤
【81573】Re:VBA データが多い場合
回答  ［名前なし］  - 20/12/12(土) 20:15 -
引用なし
パスワード
   Sub deta()

Dim Sh1 As Worksheet, Sh2 As Worksheet
Dim forNo As Variant, toNo() As Variant
Dim setRow As Integer, cMax As Integer
Dim aRange As Range, bRange As Range
Dim toRow As Integer, toCol As Integer
Dim i As Double, foi As Double, toi As Double, n As Integer

forNo = Array("A1", "C1", "G1", "B1") 'コピー元（Sh1）のセル位置
toNo = Array("A1", "B1", "C1", "B2")　'コピー先(Sh2）のセル位置
setRow = 2　　　　　　　　　　　　　　'コピー先１セットの行数


cMax = UBound(forNo)
Set Sh1 = ThisWorkbook.Sheets("シート１")
Set Sh2 = ThisWorkbook.Sheets("シート２")

Set aRange = Sh1.Range("A1").CurrentRegion '元データー範囲
'Set aRange = Intersect(aRange, aRange.Offset(1, 0)) '１行目を省く
Set aRange = Intersect(aRange, aRange.Columns(1)) 'A列に絞る
'aRangeのセル数（行数）分転記する。
Sh2.Range("A1:ZZ1000").ClearContents　　　'転記先をクリアー？

For Each bRange In aRange
　 i = bRange.Rows.Row
　 foi = i - 1
　 toi = foi * setRow
　　 Debug.Print bRange.Address, i, toi
　 For n = 0 To cMax
　　　Sh2.Range(toNo(n)).Offset(toi, 0).Value = Sh1.Range(forNo(n)).Offset(foi, 0).Value
　 Next
Debug.Print bRange.Address, i, toi
Next

Set aRange = Nothing
Set bRange = Nothing
Set Sh1 = Nothing
Set Sh2 = Nothing

End Sub
  新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム  
199 / 13645 ﾂﾘｰ ←次へ　｜　前へ→
ページ：  ┃  記事番号：
2610219
(SS)C-BOARD v3.8 is Free