Excel VBA質問箱 IV

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

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


1652 / 13644 ツリー ←次へ | 前へ→

【72858】列ごとに別シートを追加し、データをコピーしたい おにこ 12/9/25(火) 16:52 質問[未読]
【72859】Re:列ごとに別シートを追加し、データをコ... UO3 12/9/25(火) 17:38 発言[未読]
【72868】Re:列ごとに別シートを追加し、データをコ... おにこ 12/9/26(水) 10:14 お礼[未読]

【72858】列ごとに別シートを追加し、データをコピ...
質問  おにこ  - 12/9/25(火) 16:52 -

引用なし
パスワード
   元シートにあるデータを列分だけ追加して、データをコピーしたいです。
1.元シートにあるデータはA列〜AH列の34列ですので、34シート追加したいです。
2.どの新シートも固定で
A列:元シートのP列
B列:元シートのW列
3.C列は1列毎のデータをコピー
4.シートのタイトル名はそれぞれの列の1行目の項目
にしたいです。
-----------------------------------
例)
■元シートのA1セル:「みかん」の場合、新シート名は「みかん」
シート名「みかん」のC列は、元シートのA列のデータのコピー
A列:元シートのP列
B列:元シートのW列


■元シートのB1セル:「りんご」の場合、新シート名は「りんご」
シート名「りんご」のC列は、元シートのB列のデータのコピー
A列:元シートのP列
B列:元シートのW列
-----------------------------------


うまく伝わりますでしょうか?
Sheets("新シート").Columns("A:A").Value = Sheets("元シート").Columns("P:P").Value
で1ページずつやってみたのですが、大変時間がかかりうまく出来ませんでした。

【72859】Re:列ごとに別シートを追加し、データを...
発言  UO3  - 12/9/25(火) 17:38 -

引用なし
パスワード
   ▼おにこ さん:

要件を誤解していたらごめんなさい。


Sub Sample1()
  Dim x As Long
  Dim z As Long
  Dim n As Long
  Dim sh As Worksheet
  Dim colP As Variant
  Dim colW As Variant
  
  Application.ScreenUpdating = False
  
  Set sh = Sheets("Sheet1")  '元シート
  z = sh.UsedRange.Cells(sh.UsedRange.Cells.Count).Row
  
  colP = sh.Columns("P").Resize(z).Value
  colW = sh.Columns("W").Resize(z).Value
  
  n = Sheets.Count
  Sheets.Add after:=Sheets(Sheets.Count), Count:=34
  
  For x = 1 To 34
    With Sheets(n + x)
      .Range("A1").Resize(z).Value = colP
      .Range("B1").Resize(z).Value = colW
      .Range("C1").Resize(z).Value = sh.Columns(x).Resize(z).Value
      .Name = sh.Cells(1, x).Value
    End With
  Next
  
  Application.ScreenUpdating = True
  MsgBox "転記終了"
  
End Sub

【72868】Re:列ごとに別シートを追加し、データを...
お礼  おにこ  - 12/9/26(水) 10:14 -

引用なし
パスワード
   ▼UO3 さん:おはようございます。
早急に回答していただきありがとうございます。
これを元に勉強させていただきます。
やりたい事が出来ました!
本当にありがとうございました!!

>▼おにこ さん:
>
>要件を誤解していたらごめんなさい。
>
>
>Sub Sample1()
>  Dim x As Long
>  Dim z As Long
>  Dim n As Long
>  Dim sh As Worksheet
>  Dim colP As Variant
>  Dim colW As Variant
>  
>  Application.ScreenUpdating = False
>  
>  Set sh = Sheets("Sheet1")  '元シート
>  z = sh.UsedRange.Cells(sh.UsedRange.Cells.Count).Row
>  
>  colP = sh.Columns("P").Resize(z).Value
>  colW = sh.Columns("W").Resize(z).Value
>  
>  n = Sheets.Count
>  Sheets.Add after:=Sheets(Sheets.Count), Count:=34
>  
>  For x = 1 To 34
>    With Sheets(n + x)
>      .Range("A1").Resize(z).Value = colP
>      .Range("B1").Resize(z).Value = colW
>      .Range("C1").Resize(z).Value = sh.Columns(x).Resize(z).Value
>      .Name = sh.Cells(1, x).Value
>    End With
>  Next
>  
>  Application.ScreenUpdating = True
>  MsgBox "転記終了"
>  
>End Sub

1652 / 13644 ツリー ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free