エクセルＶＢＡについて（オートフィルタ＆シート名変更＆コピー＆貼り付け）

質問

sheet1にデータがあります。sheet2にフォーマットがあります。
sheet1は、
A1:店名　B1:種別　C1:管轄　D1:9時 E1:10時 F1:11時・・・R1:23時
●●店　新規　 東京　　0 5 3・・・2
●●店　解約　 東京　　1 2 1・・・0
▲▲店　新規　 大阪　　0 1 1・・・2
▲▲店　解約　 大阪　　0 1 3・・・1
◆◆店　新規　 福岡　　1 3 0・・・2
◆◆店　解約　 福岡　　0 1 1・・・0
↓ずらっと各店舗毎のデータが並んでいます。
sheet2は、フォーマットになっているので、
まず、sheet2のフォーマットのシートをコピーし、
sheet1のデータをフィルタで検索し、そのセルD1:R1の項目データをコピーし、
sheet2の決まった場所(セルD33:R34)へ値貼り付け、シート名を店名に変更し、ファイル名は管轄名で保存する。
これを自動で全データ分ファイル分けしたいです。数が多くて一つ一つしていくと時間がかかりとても時間がかかりすぎます。
データから店舗名分シートを増やしていき、各データを値貼り付け、最終的には管轄でまとめて保存したいのです。

自動記録までわかるのですが、一つの自動記録を繰り返すことが、初心者でしてわかりません。VBAを使って訂正することが難しいので、どうぞよろしくお願い致します。

回答No.2

matsu_jun · ベストアンサー

A1からA40まで上から順になめていき、40まで行かなくても空白になったら(最後の行で)処理をとめたいのであれば、

Dim i As Integer
'Dim ArrayCol(40) As String

For i = 1 To Worksheets("Sheet1").Cells(1, 1).End(xlDown).Row
' ArrayCol(i) = Worksheets("Sheet1").Cells(i, 1).Value

'-----------------
'この位置に繰り返す処理を記述
'-----------------

' If i = 40 Then Exit For
Next i

あえてArrayColを使う必要も無いのですが、どうしても店名をメモリ上に確保しておきたければ、上のソースの3行のコメントを外せばOKです。

さぞお困りのことと存じますが、昨夕の質問

http://okweb.jp/kotaeru.php3?q=1235858

と合わせ見てみると、おそらく上のアドバイスでは問題は解決しない、というか、miechinさんの必要なマクロを自力で完成するのは、失礼ながら困難であろうと思われます。土日で良ければご満足のゆくマクロを作っても良いのですが、それでOKであれば、補足欄にでもその旨記入しておいて下さい。書ききれていない要望があったらついでに書いておいて下さい。

補足

ご回答ありがとうございます。ただ今、混乱して苦戦しています。
もし、お時間いただいて作成していただけるのなら、よろしくお願いいたします。無理をいって申し訳ございません。とても嬉しいです。
追加事項は、>sheet2の決まった場所(セルD33:R34)へ値貼り付け、
その後、その部分の並び替え(降順)をしたいです。
よろしくお願いいたします。

回答No.3

matsu_jun

完成しましたので記載します。ただ補足の
> その後、その部分の並び替え(降順)をしたいです。
というのが少々分かりません。何を(どの列を)キーに降順に並べるのでしょう？
質問文から、各店毎に「新規」と「解約」の2行ずつあるようなので、「新規」を33行目に、「解約」を34行目に挿入するようにしてみましたが、いかがでしょうか？

下のソースを標準モジュールに貼り付けてもらえば動作すると思います。シートの名前や各項目の列・行について、簡単に変更できるようにしてあります。

直接細かく仕様を伺ったり、入ってくるデータの個数などについて細かく打ち合わせれば、より細かなエラーチェックや動作の高速化が図れますが、このソースでは、極力エラーが発生しないような作りをしている関係上、動作が非常に遅く(処理がまだるっこしく)なっております。データ量にもよりますが、実行に最悪数分かかるかもしれません。それで問題なければご利用ください。

'ここから--------------------------------------------------------------------------------------

Sub データ編集()

'動作内容-------------------------------------------------------------------
'本マクロを実行することで、データを整理します。
'本ブックのあるフォルダに"年月日時分秒"(YYYYMMDDhhmmss)という名前のフォルダを作成し、
'その中にデータを挿入してゆきます。
'---------------------------------------------------------------------------

'変更可能な変数の定義-------------------------------------------------------
'以下を変更することで、動作方法を変更することができます。

データシート名$ = "Sheet1" 'データ入力シートのシート名です。""の中身を自由に変更できます。
テンプシート名$ = "Sheet2" 'テンプレートシートのシート名です。""の中身を自由に変更できます。
管轄列$ = "C" '管轄が記入されている列です。""の中身をAからZまで変更できます。
店名列$ = "A" '店名が記入されている列です。""の中身をAからZまで変更できます。
種別列$ = "B" '新規・解約の別が記入されている列です。""の中身をAからZまで変更できます。
開始列$ = "D" 'データコピーを開始する列です。""の中身をAからZまで変更できます。
終了列$ = "R" 'データコピーを終了する列です。""の中身をAからZまで変更できます。
新規行# = 33 '新規件数を記入する行です。= の後ろを自由に変更できます。
解約行# = 34 '解約件数を記入する行です。= の後ろを自由に変更できます。

'---------------------------------------------------------------------------

'使用上の注意点-------------------------------------------------------------
'・上の2つのシート以外にシートがあっても構いません。本ソフトはそれを無視します。
'・データシートは2行目から始まるものとします。1行目はタイトル(項目名)と考えます。
'・店舗名および管轄名には、以下の制約があります。
'　　・":"、"\"、"/"、"?"、"*"、"["、"]"、"."の8種類の文字は使ってはいけません。
'　　・店舗名および管轄名は未記入(空白)ではいけません。
'　　・文字数が31文字を超えてはいけません。
'・33行目にその店舗の「新規」データが、34行目にその店舗の「解約」データが挿入されます。(初期値)
'---------------------------------------------------------------------------

'変更不可な変数の定義-------------------------------------------------------
Dim FILE_PATH As String '本ファイルのパス
Dim FILE_FLD As String 'データ格納フォルダ名
Dim FULL_PATH As String 'データ格納フォルダのパス
Dim CHK_LINE As Long 'チェック行
Dim DB_WS As Worksheet 'データ入力シート名
Dim TP_WS As Worksheet 'テンプレートシート名
Dim COLALL(5) As Integer '列情報(COLALL(1)=管轄列、COLALL(2)=店名列、COLALL(3)=種別列)
Dim ROWALL(2) As Long '行情報(ROWALL(1)=新規行、ROWALL(2)=解約行)
Dim ERRSTR(8) As String '禁則文字
'---------------------------------------------------------------------------

On Error GoTo ERREND

Set DB_WS = Worksheets(データシート名)
Set TP_WS = Worksheets(テンプシート名)
COLALL(1) = Asc(LCase(管轄列)) - 96
COLALL(2) = Asc(LCase(店名列)) - 96
COLALL(3) = Asc(LCase(種別列)) - 96
COLALL(4) = Asc(LCase(開始列)) - 96
COLALL(5) = Asc(LCase(終了列)) - 96
ROWALL(1) = 新規行
ROWALL(2) = 解約行
ERRSTR(1) = ":"
ERRSTR(2) = "\"
ERRSTR(3) = "/"
ERRSTR(4) = "?"
ERRSTR(5) = "*"
ERRSTR(6) = "["
ERRSTR(7) = "]"
ERRSTR(8) = "."

'あらかじめオープンしているブック、管轄名、店舗名に対してエラーチェックを行う
If Workbooks.Count <> 1 Then
MsgBox ("他のワークブックを閉じてから再実行してください")
Exit Sub
End If
For CHK_LINE = 2 To DB_WS.Cells(65535, COLALL(1)).End(xlUp).Row
Dim ErrFlug As Boolean
ErrFlug = False
For i# = 1 To 2
If DB_WS.Cells(CHK_LINE, COLALL(i)).Value = Empty Then
DB_WS.Cells(CHK_LINE, COLALL(i)).Select
MsgBox ("セルに管轄名または店舗名を記入してください")
Exit Sub
End If
If LenB(DB_WS.Cells(CHK_LINE, COLALL(i)).Value) > 31 Then
DB_WS.Cells(CHK_LINE, COLALL(i)).Select
MsgBox ("管轄名または店舗名は半角31文字までです")
Exit Sub
End If
For j# = 1 To Len(DB_WS.Cells(CHK_LINE, COLALL(i)).Value)
For k# = 1 To 8
If Mid(DB_WS.Cells(CHK_LINE, COLALL(i)).Value, j, 1) = ERRSTR(k) Then
DB_WS.Cells(CHK_LINE, COLALL(i)).Select
MsgBox ("「 : \ / ? * [ ] . 」は管轄名または店舗名として利用できません")
Exit Sub
End If
Next k
Next j
Next i
Next CHK_LINE

Application.ScreenUpdating = False

'時刻を拾って結果格納フォルダを作成する。
FILE_PATH = ThisWorkbook.Path
FILE_FLD = Format(Now(), "YYYYMMDDhhmmss")
FULL_PATH = FILE_PATH & "\" & FILE_FLD
MkDir FULL_PATH

For CHK_LINE = 2 To DB_WS.Cells(65535, COLALL(1)).End(xlUp).Row
On Error Resume Next
'ブックオープン処理
Workbooks.Open FULL_PATH & "\" & DB_WS.Cells(CHK_LINE, COLALL(1)).Value & ".xls"
If Err.Number <> 0 Then 'ブック未作成の時は作成する
Err.Number = 0
On Error GoTo ERREND
Workbooks.Add
TP_WS.Copy Before:=Workbooks(2).Worksheets(1)
Workbooks(2).Worksheets(1).Name = DB_WS.Cells(CHK_LINE, COLALL(2)).Value
For i = Workbooks(2).Worksheets.Count To 2 Step -1
Application.DisplayAlerts = False
Workbooks(2).Worksheets(i).Delete
Application.DisplayAlerts = True
Next i
Workbooks(2).SaveAs (FULL_PATH & "\" & DB_WS.Cells(CHK_LINE, COLALL(1)).Value & ".xls")
End If
Dim SHTEXISTFLG As Boolean
SHTEXISTFLG = False
'データコピー処理
For i = 1 To Workbooks(2).Worksheets.Count 'シート未作成の時は作成する
If Workbooks(2).Worksheets(i).Name = CStr(DB_WS.Cells(CHK_LINE, COLALL(2)).Value) Then
SHTEXISTFLG = True
Exit For
End If
Next i
If SHTEXISTFLG = False Then
TP_WS.Copy After:=Workbooks(2).Worksheets(Workbooks(2).Worksheets.Count)
Workbooks(2).Worksheets(Workbooks(2).Worksheets.Count).Name = DB_WS.Cells(CHK_LINE, COLALL(2)).Value
End If
If DB_WS.Cells(CHK_LINE, COLALL(3)).Value = "新規" Then '新規の件数か、解約の件数かを判断する
i = ROWALL(1)
Else
i = ROWALL(2)
End If
For j = COLALL(4) To COLALL(5)
Workbooks(2).Worksheets(CStr(DB_WS.Cells(CHK_LINE, COLALL(2)).Value)).Cells(i, j).Value = _
DB_WS.Cells(CHK_LINE, j).Value
Next j
Workbooks(2).Close (True)
Next CHK_LINE
MsgBox ("データ整理が正常に完了しました")
ERREND:
If Err.Number <> Empty Then
MsgBox Error(Err.Number)
End If
Application.ScreenUpdating = True
End Sub

'ここまで--------------------------------------------------------------------------------------

なお、この答えを書き込もうとしたら
「機種依存文字が・・・」という表示が出てきて、この答えのどこかが変わってしまったみたいです。
恐らくどこかの漢字だと思いますし、その漢字を使った箇所全てが入れ替わっているはずなので問題ないとは思いますが。。。
問題ありましたら、また連絡ください。

回答No.1

ykym

ループ処理をする命令"For"を使います。
以下のコードは概要ですが

Dim ArrCol As Variant
Dim StrShop As String

ArrCol = Array("●●店", "▲▲店", "◆◆店")

For Each StrShop In ArrCol

'-----------------
'この位置に繰り返す処理を記述
'-----------------

Next

まず、繰り返しをするためのすべての要素の配列を作成します。
その次の"For Each"命令でそのすべてを順に処理します。
上のコードの場合"For Each" 命令から "Next"命令の間は"StrShop"
変数で店名を参照できますので検索するための命令に使用してください。
処理する店を増やす場合には"Array"文の括弧の中に新しい店名をカンマ
で区切って追加してください。

お礼

ご回答ありがとうございます。
店名が４０ぐらいあったりするのですが、
ArrCol = Array("●●店", "▲▲店", "◆◆店")へ全部の店名を入れると長くなるのですが、sheet1の(A1:A40)空白になったら終わり。というようなのはできないでしょうか？
初心者でして混乱しています。申し訳ございませんが再度ご回答いただけないでしょうか。よろしくお願いいたします。