Excel (VBA)

Excel VBAに関するフォーラムです。
  • 解決済みのトピックにはコメントできません。
このトピックは解決済みです。
質問

 
(Windows 7 Professional : Excel 2010)
シートのフィールドの値毎にブックに保存
投稿日時: 17/12/03 16:46:48
投稿者: 馬車道停留所

 
こんにちは
  
一覧シートのB列の値毎に(支店別に)エクセルブックに保存する方法についてご教授ください。
 下記のVBAは、支店別にシート毎に分けて保存するものなのですが、
 支店別に、ブック毎に保存する際に、表紙シートと、一覧の見出し3行目も保存したいです。
 下記のVBAは、A4に値から値を貼り付けて保存するものです。
  
よろしくお願いします。
  
【表紙】
ブック内のハイパーリンクが保存されています。また、一覧の部署を関数で表示しています。
 例:システム1をクリックすると、一覧のシステム1の見出しに飛びます。
  
【一覧】
 行は、10,000、列は、(システム20)ぐらいまで横並びで、120ほどあります。
  
項目 システム1 システム2
A:担当 B:支店 C:ID D:権限@ E:権限A F:ID G:権限@ H:権限A.....
担当者3 支店A 1234569 利用者 S003 2345680 管理者 F003
担当者7 支店A 1234573 利用者 S007 2345684 管理者 F007
担当者10支店B 1234576 利用者 S010 2345687 管理者 F010
担当者12支店B 1234578 利用者 S012 2345689 管理者 F012
担当者14支店C 1234580 利用者 S014 2345691 管理者 F014
担当者17支店C 1234583 利用者 S017 2345694 管理者 F017
 .
 .
 .
   
【VBA】
Sub Sample()
   Dim Dic As Object
   Dim ws0 As Worksheet
   Dim ws1 As Worksheet
   Dim K As String
   Dim RR As Range
   Dim R As Range
   Set Dic = CreateObject("Scripting.Dictionary")
   Set ws0 = Worksheets("一覧")
   With ws0
     Set RR = .Range("B5")
     Set RR = .Range(RR, RR.End(xlDown))
     Application.ScreenUpdating = False
     For Each R In RR
       K = R.Value
       If Dic.Exists(K) Then
       Else
         Dic(K) = Empty
         RR.Offset(-1).Resize(, 15).AutoFilter 1, K
         Set ws1 = Worksheets.Add(, Worksheets(Worksheets.Count))
         .Range("A5", .Cells(.Rows.Count, 1).End(xlUp)) _
                 .Resize(, 15).Copy ws1.Range("A4")
         ws1.Name = K
         Set ws1 = Nothing
       End If
     Next R
     .AutoFilterMode = False
     Application.ScreenUpdating = True
   End With
   Set Dic = Nothing: Set RR = Nothing: Set ws0 = Nothing
  End Sub

回答
投稿日時: 17/12/03 18:04:48
投稿者: WinArrow
投稿者のウェブサイトに移動

説明がよくわかりません。
 
要は
「支店ごと」に、データを新ブックに複写して、保存したいのではないでしょうか?
 
コードの中では、新しいシートに複写しているようですが・・・ブックとしての保存がない??
 
このマクロは、どのブックに記述されているんですか?

投稿日時: 17/12/03 18:45:16
投稿者: 馬車道停留所

WinArrowさん
 
ご返信ありがとうございます。
 
> 要は「支店ごと」に、データを新ブックに複写して、保存したいのではないでしょうか?
 > はい。その通りです。
 
> コードの中では、新しいシートに複写しているようですが・・・ブックとしての保存がない??
 > はい。今のVBAには、ブックとしての保存がないので、シートではなく、ブックに保存したいです。
   その際、単に、A4行以降にデータを複写するのみではなく、
   基ファイルの表紙シートと、一覧シートの見出し3行も、そのまま残して保存したいです。
 
> このマクロは、どのブックに記述されているんですか?
 > 基ファイル(確認.xlsm)のThisworkbookです。
   基ファイルには、表紙シートと、一覧シートがあります。
   基ファイルの一覧シートには、全支店のデータが一つになっています。
 
【分割後のイメージ】
 ファイル名:確認(支店A).xlsx 
 基ファイルがあるディレクトリーに、支店の数だけファイルを作成。
 それぞれのブックに含まれるシート:表紙、一覧
 
 一覧シートには、基ファイルの一覧シートの見出し3行、120列程度を複写。
  A4以降に、支店Aのデータのみ表示(10,000行のうち、B列が支店Aとなっているレコードのみ)。
   
 

回答
投稿日時: 17/12/03 19:30:45
投稿者: WinArrow
投稿者のウェブサイトに移動

ヒント
 
(1)支店名をユニークにしたデータを作成します。
 方法1:「統合」コマンドを使う・・・作業シートに作成したらよいと考えます。
     それを配列変数に格納します。
 方法2:B列セルをループして配列変数に格納します。
 
(2)一覧シートにAUtoFilterを設定し、
 支店名配列から1つづつ、AutoFilter検索し、表示されているシートを新しブックに複写します。
 
(3)表示シートを(2)で作成したブックに複写します。
 
(4)新しいブックを名前を付けて保存します。
 
こんな手順でいかがでしょうか?
 

回答
投稿日時: 17/12/03 19:53:32
投稿者: WinArrow
投稿者のウェブサイトに移動

↑で紹介した「統合」による支店名データを作業用シートに作成するコードです。
 
作業用データに「Sheet2」をつかっっています。
 
Dim MOTO As String
    With Sheets("sheet1")
        MOTO = .Name & "!" & .Range("B3:C" & .Range("B" & .Rows.Count).End(xlUp).Row).Address(ReferenceStyle:=xlR1C1)
    End With
    Sheets("Sheet2").Range("A1").Consolidate _
        Sources:=MOTO, _
        Function:=xlsum, _
        LeftColumn:=True
    
 
なおSheet2シートのB列は不要です。
 

投稿日時: 17/12/04 19:49:02
投稿者: 馬車道停留所

WinArrowさん
 
分割マクロ(.xlsm)と、基データ(.xlsx)を分けて作成し、表紙も各ブックにコピーして個別のファイルを作成することができました。
 
ありがとうございました。