複数シートの一部をシート一枚にまとめるには？

質問

住所録があります。　一枚のシートに住所、名前、電話番号が横にならんで３つのセルに記載されているのですが毎月１００シートほど出来上がっておりこれを一枚のシートに手入力で転記しております。
あまりにも非効率的なのでＶＢＡ等で一括処理をしたいのですがどうすればよいでしょうか？

回答No.2

Wendy02 · ベストアンサー

こんにちは。
既に回答は出ているようですが、こんな風にしたらどうでしょうか。

iHEAD オプションのタイトルというのは、

　住所　　名前　　電話番号

こうなっていることです。

すでに集計用のシートが決まっているなら、このようにします。
ただし、集計用のシートは、右端に追いやられます。

先頭に、(') をいれ、コメントブロックします。
　 'Set DataSh = .Worksheets.Add(After:=.Worksheets(.Worksheets.Count))

コードのコメントブロックを外します。
　''集計用のシートがすでに決まっているなら、上の行に、「'」を付けて、ここに登録する
　 Set DataSh = .Worksheets(シート名)
　　If DataSh.Index <> .Worksheets.Count Then
　　　　DataSh.Move After:=.Worksheets(.Worksheets.Count)
　　End If

行が満杯になったら、新しいシートが右隣に、加えられます。

標準モジュール
'-----------------------------------------------
Sub TransferData()
　　Dim DataSh As Worksheet
　　Dim i As Integer
　　Dim j As Long
　　Dim n As Long
　　Dim k As Integer
　　Const iHEAD As Integer = 1 '(0はタイトルなし、1はタイトルあり）
　　If iHEAD > 1 And iHEAD < 0 Then MsgBox "iHEAD エラー!", , "定義エラー": Exit Sub
　　Const mErrNum As Integer = 513

　　With ActiveWorkbook
　　　　'--------------------
　　　　Set DataSh = .Worksheets.Add(After:=.Worksheets(.Worksheets.Count))

　　　　''集計用のシートがすでに決まっているなら、上の行に、「'」を付けて、ここに登録する
　　　　'Set DataSh = .Worksheets("Sheet1")
　　　　'If DataSh.Index <> .Worksheets.Count Then
　　　　'　DataSh.Move After:=.Worksheets(.Worksheets.Count)
　　　　'End If

　　　　If iHEAD > 0 Then
　　　　　　.Worksheets(1).Range("A1:C1").Copy DataSh.Range("A1")
　　　　End If
　　　　'--------------------
　　　　k = 1 'データ集計シート

　　　　On Error GoTo ErrHandler
　　　　For i = 1 To .Worksheets.Count - k
　　　　　　Application.ScreenUpdating = False
　　　　　　With .Worksheets(i)
　　　　　　　　j = DataSh.Cells(Rows.Count, 1).End(xlUp).Offset(1).Row
　　　　　　　　If iHEAD = 0 And j = 2 Then j = 1
　　　　　　　　n = .Cells(Rows.Count, 1).End(xlUp).Row
　　　　　　　　If (j + n) < Rows.Count Then
　　　　　　　　　　.Range(.Range("A1").Offset(iHEAD), .Cells(Rows.Count, 1).End(xlUp).Offset(, 2)).Copy _
　　　　　　　　　　DataSh.Cells(j, 1)
　　　　　　　　Else
　　　　　　　　　　Err.Raise 513
　　　　　　　　End If
　　　　　　End With
　　　　　　Application.ScreenUpdating = True
　　　　Next

ErrHandler:
　　　　If Err.Number = mErrNum Then
　　　　　　Set DataSh = .Worksheets.Add(After:=.Worksheets(.Worksheets.Count))
　　　　　　i = i - 1
　　　　　　If iHEAD > 0 Then
　　　　　　　　.Worksheets(1).Range("A1:C1").Copy DataSh.Range("A1")
　　　　　　End If
　　　　　　k = 2
　　　　　　Resume Next
　　　　ElseIf Err.Number > 0 Then
　　　　　　MsgBox Err.Number & ": " & Err.Description
　　　　End If
　　End With
　　Set DataSh = Nothing
End Sub

回答No.1

n-jun

一番左に新規でワークシートを作成して、そこへ纏めます。
ただしワークシートの行数をオーバーした際の処理は入れてません。

Sub　test()
　Dim　ws　As　Worksheet
　Dim　r1　As　Range,　r2　As　Range
　Dim　i　As　Integer

　Worksheets.Add　Before:=Worksheets(1)
　Set　ws　=　ActiveSheet
　Set　r1　=　ws.Range("A1")

　Application.ScreenUpdating　=　False

　For　i　=　2　To　Worksheets.Count
　　　　　Set　r2　=　Worksheets(i).Range("A1").CurrentRegion
　　　　　r2.Copy　r1
　　　　　Set　r1　=　r1.Offset(r2.Rows.Count)
　Next

　Application.ScreenUpdating　=　True

　Set　ws　=　Nothing
　Set　r1　=　Nothing
　Set　r2　=　Nothing
End　Sub
ご参考になれば幸いです。