マクロについて

質問

エクセルのマクロについて質問です。

シート１にデータが入っており
A列に入っているデータを営業所ごとにまとめて抽出し
雛形シートをコーピーしてデータを貼り付け、シート名をA列の営業所名にしたいのですが
可能でしょうか？

例えば

　A列　　　　　　　B列　　C列　
　東京営業所　　30個　　500円
　大阪営業所　　10個　　200円
　東京営業所　　5個　　　100円

↓↓↓

　A列　　　　　　　B列　　C列　
　東京営業所　　30個　　500円
　東京営業所　　5個　　　100円

シート名　東京営業所
---------------------------------------

　A列　　　　　　　B列　　C列　
　大阪営業所　　10個　　200円

シート名　大阪営業所

毎回手作業で、どなたか教えていただけますと助かります。

回答No.3

keithin · ベストアンサー

データの入っているSheet1と、ひな形にする雛形シートを用意します

手順：
ＡＬＴ＋Ｆ１１を押す
現れた画面で挿入メニューから標準モジュールを挿入する
現れたシートに下記をコピー貼り付ける

sub macro1()
　dim r as long
　on error goto errhandle

’コピーする
　for r = 2 to worksheets("Sheet1").range("A65536").end(xlup).row
　worksheets("Sheet1").cells(r, "A").resize(1, 3).copy _
　worksheets(worksheets("Sheet1").cells(r, "A").value).range("A65536").end(xlup).offset(1)
　next
　exit sub

errhandle:
’シートを用意する
　worksheets("雛形").copy after:=worksheets(worksheets.count)
　activesheet.name = worksheets("Sheet1").cells(r, "A").value
　resume
end sub

ファイルメニューから終了してエクセルに戻る
ＡＬＴ＋Ｆ８で実行する。

お礼

keithin様

今帰宅してきましたので、明日実行してみたいと思います。
遅い時間にご回答ありがとうございます。
助かりますｍ（＿＿）ｍ

回答No.4

K Kazz（@JazzCorp）

'各シートの先頭は見出し
'レコードは１行以上必要
Sub JournalizeSheet()
Dim kk As Long
Dim MaxRow As Long
Dim strSheet As String
Dim OldSheet As Worksheet
Dim NewSheet As Worksheet
Dim xNewSheet As Boolean

Application.ScreenUpdating = False
Application.DisplayAlerts = False

Worksheets("sheet1").Activate
MaxRow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
For kk = 2 To MaxRow
strSheet = Worksheets("sheet1").Range("A" & kk)
If (strSheet = "") Then Exit For

Set OldSheet = ActiveSheet
xNewSheet = True
For Each OldSheet In Worksheets
If OldSheet.Name = strSheet Then
xNewSheet = False
End If
Next
If (xNewSheet) Then
Worksheets.Add after:=Worksheets(Worksheets.Count)
' On Error Resume Next
ActiveSheet.Name = strSheet
Set NewSheet = ActiveSheet
Worksheets("sheet1").Rows(1).Copy
NewSheet.Range("A1").PasteSpecial
Else
Set NewSheet = Worksheets(strSheet)
End If
' OldSheet.Activate
Worksheets("sheet1").Rows(kk).Copy
NewSheet.Cells(Rows.Count, 1).End(xlUp).Offset(1).PasteSpecial
Next kk

Epilogue:
Worksheets("Sheet1").Select
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

お礼

JazzCorp様
ご回答ありがとうございます
やり方がこんなに沢山あるとは思わず
凄くびっくりしました。本当にありがとうございます！！

回答No.2

tsubuyuki

あ、すいません。補足です。
１行目に「項目列」が存在すると仮定したコードです。

ご注意くださいませ。

お礼

tsubuyuki　様

早速の回答ありがとうございます！！
マクロ初心者なもので、ちんぷんかんぷんです。
ActiveSheet.Name = strSheetの所でエラーになってしまうのですが
どうしたら良いのでしょうか。。

ちなみに、雛形シートと言うのをコピーしてA７にデータを貼り付けたいのですが
お助けいただけますと助かります。

回答No.1

tsubuyuki

少々くどいコードになってしまいましたが、一例として。

Sub test()
Dim i As Integer
Dim MaxRow As Integer, TagRow As Integer
Dim strSheet As String, ExSheet As Worksheet
Dim ConSheet As Integer
Dim OldSheet As Worksheet, NewSheet As Worksheet

　MaxRow = Range("A1").End(xlDown).Row

　　For i = 2 To MaxRow
　　　ConSheet = 0
　　　strSheet = Range("A" & i)
　　　Set OldSheet = ActiveSheet

　　　For Each ExSheet In Worksheets
　　　　If ExSheet.Name = strSheet Then
　　　　　ConSheet = ConSheet + 1
　　　　End If
　　　Next

　　　If ConSheet = 0 Then
　　　　Worksheets.Add after:=Worksheets(Worksheets.Count)
　　　　ActiveSheet.Name = strSheet
　　　　Set NewSheet = ActiveSheet

　　　　OldSheet.Rows(1).Copy
　　　　NewSheet.Range("A1").PasteSpecial
　　　Else
　　　　Set NewSheet = Worksheets(strSheet)
　　　End If

　　　OldSheet.Rows(i).Copy
　　　NewSheet.Range("A65535").End(xlUp).Offset(1).PasteSpecial

　　　OldSheet.Activate
　　Next i
End Sub

以上、参考までに。