[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『膨大なデータから抽出し、別ブックに保存したい』（ポポロン）
良い案があれば教えて下さい・・・
職場でExcel 2010を使用しています。
図（https://gyazo.com/33b847631548e7ea439047a0806996d8)
図の<元データ>のような表があり、全国の都道府県の店舗データが入っているものとします。
しかしこれは、2週間分のデータが並べてあるので、同じ人の先週、今週のデータが入ってしまっています。
この表の中から、「埼玉県」の店舗のみの、オレンジの枠の部分のみのデータが必要で、
それをそれぞれの店舗ごとに名前を付けて分けて、それぞれのデータとして保存がしたいのです。
そして、そのときに、同じ人の先週、今週のデータを統合させたいのです。
その方法として、何か良い案があれば、知恵をお貸し頂きたいのです。
今まではどなたかが作ったマクロがあり、店舗別にデータを分けるまでは出来ていたのですが、
数十店舗あるバラバラになったデータを一つずつ、手作業でダブった人の分を計算していました。
（マクロを動かすブックの別シートに、必要な店舗名、店舗数が書かれており、それを元にデータ抽出をしていた様子です。このブックと同じフォルダにcsv形式の元データを入れ、店舗別のブックに分解していました。）
ExcelのVBAというかExcel自体、多少の関数以外本当に初心者で、本当に申し訳無いのですが、どうかご教授を頂ければと思います。
※参考になるかどうか分からないのですが、
今使っているコードです。
Sub 分解()
Dim Cn As ADODB.Connection
Dim RS As ADODB.Recordset
Dim GYO As Long, COL As Long
Dim strSQL As String
Dim FileCount As Integer '配列サイズ
Dim strFileName As String '自ファイル名
Dim strPath As String 'フォルダパス
Dim CSVFileName As String 'CSVファイル名
Dim mcrFileName
Dim SaveDir As String
Dim FilePW As String 'ファイルパスワード
Dim StoreCode As String '販売店コード
Dim StoreName As String '販売店名
Dim StoreCount As Long
Dim StoreWorkBook As Workbook
Dim intRow As Integer
Dim intCell As Integer
'CSVファイルのファイル名を取得
strPath = ActiveWorkbook.Path & "\"
strFileName = Dir(strPath & "\*.csv")
mcrFileName = ActiveWorkbook.Name
FileCount = 0
'*** ファイル数を数える ***
Do Until strFileName = ""
FileCount = FileCount + 1
strFileName = Dir
Loop
If FileCount > 1 Then
MsgBox "CSVファイルが２個以上あります。１個にしてください。"
Exit Sub
End If
If FileCount = 0 Then
MsgBox "CSVファイルがありません。"
Exit Sub
End If
strFileName = Dir(strPath & "*.csv")
CSVFileName = strFileName
Worksheets("店舗マスタ").Activate
StoreCount = Cells(2, 3).Value + 1
FilePW = Cells(5, 3).Value
For i = 2 To StoreCount
Worksheets("店舗マスタ").Activate
StoreCode = Cells(i, 1).Value
StoreName = Cells(i, 2).Value
'SQL接続
Set Cn = New ADODB.Connection
Cn.Provider = "Microsoft.Jet.OLEDB.4.0"
Cn.Properties("Extended Properties") = "Text;HDR=YES"
Cn.Open strPath
strSQL = ""
strSQL = strSQL & " SELECT 販売店コード,販売店名,社員名,達成件数,目標件数,達成率, ●●件数, ××件数"
strSQL = strSQL & " FROM"
strSQL = strSQL & "[" & CSVFileName & "]"
strSQL = strSQL & " WHERE 販売店コード = "
strSQL = strSQL & StoreCode
Set RS = Cn.Execute(strSQL)
'画面の再描画を抑止 ScreenUpdating = False '新しいブックを追加 Workbooks.Add
'１行目に列見出し（フィールド名）をExcelに出力
intRow = 1
For intCell = 1 To RS.Fields.Count
Cells(intRow, intCell).Value = RS.Fields(intCell - 1).Name
Cells(intRow, intCell).Borders.LineStyle = xlContinuous
Next intCell
'各レコードをExcelに出力
intRow = 2
Do Until RS.EOF
For intCell = 1 To RS.Fields.Count
If intCell = 6 Then '達成率は型を数値に変換しておく
If IsNull(RS.Fields(intCell - 1)) = True Then
Cells(intRow, intCell).Value = ""
Cells(intRow, intCell).Borders.LineStyle = xlContinuous
Else
Cells(intRow, intCell).Value = Val(RS.Fields(intCell - 1))
Cells(intRow, intCell).Borders.LineStyle = xlContinuous
End If
Else
Cells(intRow, intCell).Value = RS.Fields(intCell - 1)
Cells(intRow, intCell).Borders.LineStyle = xlContinuous
End If
Next intCell
intRow = intRow + 1
RS.MoveNext
Loop
RS.Close
'達成率の列を％表示にする Columns(6).NumberFormatLocal = "0.0%"
'列幅のジャストフィット Cells.Select Cells.EntireColumn.AutoFit
'A1セルだけを選択状態にする
Range("A1").Select
'画面の再描画を元に戻す
ScreenUpdating = True
'Excelを可視状態にする
Visible = True
Cn.Close
Set RS = Nothing
Set Cn = Nothing
SaveDir = strPath & "out\"
If Dir(SaveDir, vbDirectory) = "" Then
MkDir SaveDir
End If
Set StoreWorkBook = ActiveWorkbook
Application.DisplayAlerts = False
StoreWorkBook.SaveAs Filename:=strPath & "out\" & StoreName & Mid(CSVFileName, 20, 18) & ".xls", FileFormat:=xlExcel8, Password:=FilePW
Application.DisplayAlerts = True
StoreWorkBook.Close
Workbooks(mcrFileName).Activate
Next i
Worksheets("sheet1").Activate
MsgBox "ファイル出力が終わりました"
End Sub
＜ 使用 Excel：Excel2010、使用 OS：Windows7 ＞
＞図（https://gyazo.com/33b847631548e7ea439047a0806996d8) ＞図の<元データ>のような表があり、全国の都道府県の店舗データが入っているものとします。
ネット上のファイルにアクセスするのは抵抗があるんですが、 現物のエクセル(データは架空)を、説明に必要な範囲を選択・コピーして、 この掲示板に貼り付けられないですか？
大元から対応するのは大変なので、現在手作業で行っている部分の自動化策を考えましょうよ。
（半平太） 2017/06/20(火) 09:52
自宅に帰り次第、データを張り付けさせて頂きます。
どうぞよろしくお願いいたします。
（ポポロン） 2017/06/20(火) 12:43
こんな感じの元データがあります。
Ａ〜Ｄ、Ｈの列にもデータは入ってますが、使わない部分です。
この状態のデータの中から、今はマクロを使って、
<埼)●●店.xls>
A B C D E F G H I
456877512 埼)●●店 渡辺 4 9 44% 1 0
456877512 埼) ●●店 佐藤 3 4 75% 4 0
456877512 埼)●●店 森田 5 10 50% 3 2
456877512 埼)●●店 佐藤 2 7 29% 1 3
<埼)××店.xls>
A B C D E F G H I
<埼)□□店.xls>
A B C D E F G H I
のように、同じ人がダブっている状態で、埼玉の中、店舗ごとのデータに分けられている状態です。
この中身を手作業で足し算（Ｄ，Ｆ，Ｇ，Ｈ）、割り算（Ｆ）をして出しているような感じです。
この状態だと考えた方がもはや早いので・・。
ただいかんせん、一回の作業は少なく簡単でも、何十個ともなると、ハゲあがりそうな状態です。。
（ポポロン） 2017/06/21(水) 01:12
詰まるところ、元データから、店別のブックを作ればいいんですね？
１．レイアウトの確認 説明と若干食い違っています。レイアウトは下の通りで合っていますか？
<元シート> 行 ______F______ ____G____ __H__ ___I___ ____J____ ____K____ ___L___ __M__ __N__ 1 販売店コード 販売店名 ×× 社員名 達成件数 目標件数 達成率 ×× ×× 2 753456123 東)●●店 田中 5 8 63% 0 1 3 754651235 東)××店 藤本 2 4 50% 0 0 4 456877512 埼)●●店 渡辺 4 9 44% 1 0
<店別ブック> 行 ______A______ ____B____ __C__ ___D___ ____E____ ____F____ ___G___ __H__ __I__ 1 販売店コード 販売店名 ×× 社員名 達成件数 目標件数 達成率 ×× ×× 2 456877512 埼)●●店 渡辺 4 9 44% 1 0 3 456877512 埼)●●店 佐藤 3 4 75% 4 0 4 456877512 埼)●●店 森田 5 10 50% 3 2
２．ブックの拡張子は、全て「.xls」なんですか？ つまり、XL2003以前のバージョンの古いファイル形式？
XL2010なら、プログラムは「.xlsm」、データブックは「.xlsx」になりそうなもんですが・・
（半平太） 2017/06/21(水) 09:54
＞154121542 神)●●店 青木 4 4 100% 3 2 ＞120542157 神)●●店 吉沢 5 5 100% 4 9
販売店コードが違うのに、販売店名が同じものがありますけど、それってアリですか？
ブック名は「販売店名.xls」になるハズなので、どっちかが存在できないですけど・・・ たとえ存在できても、区別出来ないですよ？
（半平太） 2017/06/21(水) 11:05
店舗コードについて、ダミーでデータ入力するときに間違えてしまったようです。コードは店舗ごとなので、同一です。こちらも失礼しました。
拡張子なんですが、
おそらく、それぞれの店舗へ配布する場合のExcelのバージョンに合わせてるのかな？と思います。
（ポポロン） 2017/06/21(水) 12:19
＞A~D,H,M,N以外のデータ ＞E ,F ,G ,I ,J ,K, L, O, Pのデータが必要です。M、N抜けてました
E列からですか？
１．再確認の為、以下の図を訂正してください。正しい情報が提示されない場合、私は降ります。
<元ブックの1番目のデータシート> 元ブックの拡張子は「.xls」
行 _____ E _____ ____F____ ___G___ __H__ ____I____ ____J____ ___K___ _ L _ __M__ __N__ __O__ __P__
1 販売店コード 販売店名 社員名 ×× 達成件数 目標件数 達成率 ×× ×× ×× ×02 ×03
2 120542157 神)●●店 吉沢 5 5 100% 4 9
<店別ブックの1番目のシート> ブックの拡張子は「.xls」
行 ______A______ ____B____ __C__ ___D___ ____E____ ____F____ ___G___ __H__ __I__
1 販売店コード 販売店名 社員名 達成件数 目標件数 達成率
2 456877512 埼)●●店 渡辺 4 9 44%
＞ 拡張子なんですが、 ＞ おそらく、それぞれの店舗へ配布する場合のExcelのバージョンに合わせてるのかな？と思います。
２．元データも旧「.xls」ですか？
３．プログラム用のブックは新「.xlsm」でいいですね？
（半平太） 2017/06/21(水) 15:05
<元ブックの1番目のデータシート> 元ブックの拡張子は「.csv」
行 _____F____ ＿___G__＿_ __H__ ___I___ ____J_____ __＿_K____ _＿ L ___ _＿__M__＿_ __＿_N___＿ ___＿O_＿__ __＿_P___＿
1 販売店コード 販売店名 ×× 社員名 達成件数 目標件数 達成率 ×× ×× △△件数 ★★件数
2 120542157 神)●●店 吉沢 5 5 100% 4 9
<店別ブックの1番目のシート> ブックの拡張子は「.xls」
行 ______A______ ____B____ ＿__C__＿ _＿__D___＿ ____E____ ____F____ __＿_G_＿__ _＿_H＿__
1 販売店コード 販売店名 社員名 達成件数 目標件数 達成率 △△件数 ★★件数
2 456877512 埼)●●店 渡辺 4 9 44% 4 9
です。
元ブックの
Ｆ，Ｇ，Ｉ，Ｊ，Ｋ，Ｌ，Ｏ，Ｐ を抜き出し、別ブックに保存です。
2.元データは 「.csv」 でした。
3.プログラム用ブックは 「.xlsm」 です。
（ポポロン） 2017/06/21(水) 22:56
考えてみると、これって実際、何をしているのか、例示されて居なかったですね。 ↓ ＞同じ人の先週、今週のデータを統合させたいのです。 ＞数十店舗あるバラバラになったデータを一つずつ、手作業でダブった人の分を計算していました。
今まで、「達成率」の統合・再計算しか念頭になかったのですが、 G、Hが正式項目として挙がってきたと言うことは、これも合算するってことですね？
（半平太） 2017/06/22(木) 12:06
元データブック(CSVファイル）とマクロ(.xlsm）だけが開かれているものとします。
結果のファイル群は、マクロブックがあるフォルダに作成されます。 ※必然的に、上記２ファイルは一度は保存されている必要があります。
’標準モジュールに貼り付けるマクロ
Sub BRdown()
Dim WBsrc As Workbook
Dim WSsrc As Worksheet
Dim valToProc
Dim RW As Long, CL As Long
Dim PreShopCode, CurShopCode
Dim PreEmpName, CurEmpName
Dim oneLineToOut(1 To 1, 1 To 8)
Dim dataStored
Dim KK As Long, colOut As Long
Dim dicT As Object, dKey
Dim goAhead As Boolean
Set dicT = CreateObject("Scripting.Dictionary")
For Each WBsrc In Workbooks
If UCase(Right(WBsrc.Name, 4)) = ".CSV" Then
goAhead = True
Exit For
End If
Next
If goAhead Then
Set WSsrc = WBsrc.Sheets(1)
Else
MsgBox "CSVファイルが見当たりません"
Exit Sub
End If
Application.ScreenUpdating = False
'昇順にソート
With WSsrc.Sort.SortFields
.Clear
.Add Key:=Range("F2"), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortTextAsNumbers
.Add Key:=Range("I2"), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
End With
With WSsrc.Sort
.SetRange WSsrc.Range("F1").CurrentRegion
.Header = xlYes
.Orientation = xlTopToBottom
.SortMethod = xlStroke
.Apply
End With
valToProc = Intersect(WSsrc.Range("F1").CurrentRegion.Offset(1), WSsrc.Columns("F:P")).Value
For RW = 1 To UBound(valToProc)
CurShopCode = valToProc(RW, 1)
CurEmpName = valToProc(RW, 4)
If PreShopCode <> CurShopCode Then 'NewBooK
If dicT.Count > 0 Then '直前の取引先ブック作成要
Call BookMaking(dicT, WSsrc)
End If
'新規ブック用に初期化
dicT.RemoveAll
Erase oneLineToOut
PreShopCode = CurShopCode
PreEmpName = CurEmpName
End If
'書込みデータを1行準備
colOut = 0
For CL = 1 To 11
CL = IIf(CL = 3, 4, IIf(CL = 8, 10, CL))
colOut = colOut + 1
oneLineToOut(1, colOut) = valToProc(RW, CL)
Next CL
dKey = CurShopCode & CurEmpName
If dicT.exists(dKey) Then
dataStored = dicT(dKey)
For KK = 4 To 8
dataStored(1, KK) = dataStored(1, KK) + oneLineToOut(1, KK)
Next KK
dataStored(1, 6) = dataStored(1, 4) / dataStored(1, 5)
dicT(dKey) = dataStored
Else
dicT(dKey) = oneLineToOut
End If
PreEmpName = CurEmpName '
Next RW
Application.ScreenUpdating = True
MsgBox "完了"
End Sub
Private Sub BookMaking(ByRef dicT As Object, WSsrc As Worksheet)
With Workbooks.Add
With Sheets(1)
WSsrc.Range("F1:G1,I1:L1,O1:P1").Copy .Range("A1")
.Columns("A").NumberFormat = "0"
.Columns("A").AutoFit
.Columns("F").NumberFormat = "0.0%"
.Range("A2").Resize(dicT.Count, 8) = Application.Index(dicT.items, 0, 0)
.SaveAs ThisWorkbook.Path & "\" & .Range("B2").Value & ".xls", FileFormat:=xlExcel8
End With
.Close
End With
End Sub
（半平太） 2017/06/22(木) 17:15
今まで手作業でやっていた事ですが、
「達成件数、目標件数、△△件数、★★件数」をそれぞれ合算し、さらに合算した達成件数と目標件数を元に、「達成率」をＦに入力していました。
このようなマクロをお時間を裂いて作って頂き、本当にありがとうございます。
いま試しに自宅で使ってみたのですが、まさに求めていた動きをしています！感動しました！
しかし、厚かましい質問で申し訳無いのですが・・。
これですと全国の店舗のデータが作れてしまうのですが、
この中でさらに「埼）」とつく、埼玉の各店舗のデータだけを作る事は、できるのでしょうか？
（ポポロン） 2017/06/23(金) 01:31
販売店コードが同じでも、店名の頭にある県名が違うものがあるんですね？
店名の頭には必ず、"県名" プラス "）" があるんですか？ その在り様を正確にご説明ください。 ※二度手間なことは避けたいので、これへの対応で最後とします。
（半平太） 2017/06/23(金) 08:01
必ず一店舗に対し特定のコードが割り振られています。
(2) 仰る通りです。店名の前には、必ず" 埼 ＋ ) " など、県名＋)が付いています。
埼玉）ではなく、埼)です。
（ポポロン） 2017/06/23(金) 12:37
＞これですと全国の店舗のデータが作れてしまうのですが、 ＞この中でさらに「埼）」とつく、埼玉の各店舗のデータだけを作る事は、できるのでしょうか？
＞販売店コードは店舗ごとのため、全国規模でも被っている所はありません。 ＞必ず一店舗に対し特定のコードが割り振られています。
矛盾しているように思うのですが、 店舗ごとに特定コードが付いているなら、 コード毎に作ってあるので、自然体で別々になりませんか？
下の元データが有ったら 何個のブック、それに何枚のシート (各ブック1枚と理解していますが）になればいいのですか？ 現バージョンでは「3ブックで各1シート」となっているハズですけど。
販売店コード 販売店名 456877512 埼)●●店 456877512 埼)●●店
753456123 東)●●店 753456123 東)●●店
754651235 東)××店
＞埼玉）ではなく、埼)です。
県名の頭一文字では、区別が付かない都道府県がありますけど(Ex.山形、山梨)、大丈夫なんですか？
（半平太） 2017/06/23(金) 13:10
最初の質問の際に【埼玉の店舗のみのデータが必要】と書いたのですが、
全国で数千店舗あるため、埼玉のデータを作るために不要なブックがそこまで出来てしまうのも、出来れば避けたいと思った次第です。
確かに山形や山梨は山では表現できませんけど、
必要なのが埼玉だけなので、そこがどういう表現方法になっているかは説明には不要かと思い、省かせていただきました。
挙げていただいた例でいいますと、
埼)●●店 の１ブック（１シート）
のみと言うことになります。
（ポポロン） 2017/06/23(金) 18:30
＞必要なのが埼玉だけなので
「埼玉」だけの決め打ちなんですかぁ。珍しいリクエストですね。
元データブック(CSVファイル）とマクロ(.xlsm）だけが開かれているものとします。 ※ただし、CSVファイルは、処理が終わると「保存しないモードで」強制的に閉じます (連続テストは、やりにくくなりますが、実務上は問題ないと思います）
Sub BRdown()
Dim WbSrc As Workbook
Dim WsSrc As Worksheet
Dim WsMe As Worksheet
Dim valToProc
Dim RW As Long, CL As Long
Dim PreShopCode, CurShopCode
Dim PreEmpName, CurEmpName
Dim oneLineToOut(1 To 1, 1 To 8)
Dim dataStored
Dim KK As Long, colOut As Long
Dim dicT As Object, dKey
Dim goAhead As Boolean
Set dicT = CreateObject("Scripting.Dictionary")
For Each WbSrc In Workbooks
If UCase(Right(WbSrc.Name, 4)) = ".CSV" Then
goAhead = True
Exit For
End If
Next
If goAhead Then
Set WsSrc = WbSrc.Sheets(1)
Else
MsgBox "CSVファイルが見当たりません"
Exit Sub
End If
Application.ScreenUpdating = False
Set WsMe = ThisWorkbook.Sheets(1)
WsMe.Cells.ClearContents
'元データを昇順にソート 販売店名＞販売店コード＞社員名
With WsSrc.Sort.SortFields
.Clear
.Add Key:=Range("G2"), _
SortOn:=xlSortOnValues, Order:=xlAscending
.Add Key:=Range("F2"), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortTextAsNumbers
.Add Key:=Range("I2"), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
End With
With WsSrc.Sort
.SetRange WsSrc.Range("F1").CurrentRegion
.Header = xlYes
.Orientation = xlTopToBottom
.SortMethod = xlStroke
.Apply
End With
'埼玉だけ抽出して、自ブックに転記する
WsSrc.AutoFilterMode = False
WsSrc.Range("F1").AutoFilter
WsSrc.Range("F:P").AutoFilter Field:=7, Criteria1:="=埼*"
Intersect(WsSrc.AutoFilter.Range, WsSrc.Columns("F:P")).Copy WsMe.Range("A1")
WbSrc.Close False
valToProc = WsMe.Range("F1").CurrentRegion.Offset(1).Value
For RW = 1 To UBound(valToProc)
CurShopCode = valToProc(RW, 1)
CurEmpName = valToProc(RW, 4)
If PreShopCode <> CurShopCode Then 'NewBooK
If dicT.Count > 0 Then '直前の取引先ブック作成要
Call BookMaking(dicT, WsMe)
End If
'新規ブック用に初期化
dicT.RemoveAll
Erase oneLineToOut
PreShopCode = CurShopCode
PreEmpName = CurEmpName
End If
'書込みデータを1行準備
colOut = 0
For CL = 1 To 11
CL = IIf(CL = 3, 4, IIf(CL = 8, 10, CL))
colOut = colOut + 1
oneLineToOut(1, colOut) = valToProc(RW, CL)
Next CL
dKey = CurShopCode & CurEmpName
If dicT.exists(dKey) Then
dataStored = dicT(dKey)
For KK = 4 To 8
dataStored(1, KK) = dataStored(1, KK) + oneLineToOut(1, KK)
Next KK
dataStored(1, 6) = dataStored(1, 4) / dataStored(1, 5)
dicT(dKey) = dataStored
Else
dicT(dKey) = oneLineToOut
End If
PreEmpName = CurEmpName '
Next RW
WsMe.Cells.ClearContents
Application.ScreenUpdating = True
MsgBox "完了"
End Sub
Private Sub BookMaking(ByRef dicT As Object, WsMe As Worksheet)
With Workbooks.Add
With Sheets(1)
WsMe.Range("A1:B1,D1:G1,J1:K1").Copy .Range("A1")
.Columns("A").NumberFormat = "0"
.Columns("A").AutoFit
.Columns("B").AutoFit
.Columns("F").NumberFormat = "0.0%"
.Range("A2").Resize(dicT.Count, 8) = Application.Index(dicT.items, 0, 0)
Application.DisplayAlerts = False
.SaveAs ThisWorkbook.Path & "\" & .Range("B2").Value & ".xls", FileFormat:=xlExcel8
Application.DisplayAlerts = True
End With
.Close
End With
End Sub
（半平太） 2017/06/23(金) 19:59
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.