[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『複数条件が一致で別ブックに転記するマクロを高速化したい』（こば）
お世話になります。２種類の様式の違うアンケート用紙の回答を別ブックのデータベースに転記していくコードを書きましたが、 1つのファイルを転記するのに2分ぐらい掛かってしまいます。このマクロの高速化は可能でしょうか？ご教授頂けると幸いです。
仕組みとしてはマクロファイルと同じ階層にある、アンケート回答のファイルが入ったフォルダから一覧を取得して、ファイルを1つ1つ処理していく構造です。 また、アンケートはAとBの2つ種類があり、どちらかを判断して処理を行います。 また、Aのアンケートにはシートが３つあり、"【参考】R2年アンケート"を除いたシートを移動して同じ処理を行います。
_|___A____|___B____|___C____|___D____|___E____|___F___| 1|商品名 |カテゴリ|地域 | 県 | 回答1 | 回答2 | 2|商品A |おもちゃ| A市 |北海道 | | | 3|商品B |家電 | B市 |北海道 | | | ・・・データベースファイル_北海道 4|商品C |文具 | C市 |北海道 | | | 5|商品A |おもちゃ| B市 |北海道 | | | 6|商品B |家電 | C市 |北海道 | | | 7|商品C |文具 | D市 |北海道 | | | 8|商品A |おもちゃ| C市 |北海道 | | | ・ ・ ・
_|___A____|___B____|___C____|___D____|__ 1|商品名 |カテゴリ|地域 |回答１ | 2|商品A |おもちゃ|A市 | 1 | 3|商品A |おもちゃ|B市 | 3 | ・・・アンケート回答ファイルA（商品名・カテゴリ・地域が合致する行に転記） 4|商品A |おもちゃ|C市 | 4 | 5|商品B |家電 |A市 | 2 | 6|商品B |家電 |B市 | 1 | 7|商品B |家電 |C市 | 5 | 8|商品C |文具 |A市 | 1 | ・ ・ ・
_|___A____|___B____| 1| 北海道 |おもちゃ| 2| | | 3|商品名 |回答2 | 4|商品A |1 | 5|商品B |3 | ・・・アンケート回答様式B（商品名とカテゴリと県が一致する行全てに転記） 6|商品C |4 | 7|商品D |2 | 8|商品E |1 | 9|商品F |2 | 10|商品G |3 |
・
・
・
Sub 複数の条件があうものを抽出()
Dim DB_Sht As Worksheet, s一覧 As Worksheet, B_sht As Worksheet Dim wb As Workbook Dim ws As Worksheet Dim MyList() As Variant Dim LastRow As Long, n As Long, i As Long, j As Long Dim sFileName As String
Set s一覧 = Worksheets("一覧")
Set DB_Sht = Worksheets("アンケート_DB")
With s一覧
.Range("A:A").ClearContents
sFileName = Dir(ThisWorkbook.Path & "\アンケート回答\*.xlsm")
i = 1
Do Until sFileName = ""
.Cells(i, 1) = ThisWorkbook.Path & "\アンケート回答\" & sFileName
i = i + 1
sFileName = Dir()
Loop
End With
For n = 1 To s一覧.Cells(s一覧.Rows.Count, 1).End(xlUp).Row
Set wb = Workbooks.Open(s一覧.Cells(n, 1))
Select Case True
Case InStr(wb.Name, "A_アンケート")
For Each ws In Worksheets
If InStr(ws.Name, "【参考】R2年アンケート") = 0 Then
ws.Select
MyList = ws.Range("A2", Range("A" & Rows.Count). _
End(xlUp)).Resize(, 4).Value
LastRow = DB_Sht.Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To LastRow
For j = 1 To UBound(MyList)
'複数条件一致で別シート転記
If DB_Sht.Cells(i, 1) = MyList(j, 1) And _ '商品名が合致
DB_Sht.Cells(i, 2) = MyList(j, 2) And _ 'カテゴリが合致
DB_Sht.Cells(i, 3) = MyList(j, 3) Then '地域が合致
DB_Sht.Cells(i, 5) = MyList(j, 4)
End If
Next j
Next i
End If
Next
Erase MyList
Case InStr(wb.Name, "B_アンケート")
Set B_sht = Sheets("B_アンケート結果")
B_sht.Select
MyList = B_sht.Range("A4", Range("A" & Rows.Count). _
End(xlUp)).Resize(, 3).Value
'最終行
LastRow = DB_Sht.Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To LastRow
For j = 1 To UBound(MyList)
'複数条件一致で別シート転記
If DB_Sht.Cells(i, 1) = B_sht.Cells(j, 1) And _ '商品名が合致
DB_Sht.Cells(i, 2) = MyList.Range("B1")And _ 'カテゴリが合致
DB_Sht.Cells(i, 6) = MyList_C(j, 2)
End If
Next j
Next i
Erase MyList
Case Else
MsgBox "ファイル名を確認してください"
End Select
wb.Close SaveChanges:=False
Next n
End Sub
＜ 使用 Excel：Excel2019、使用 OS：Windows10 ＞
無意味にシートをselectしていませんか？
斜め読みですが、シートオブジェクトは明示してある様に見えるので
(Activesheetに依存しない記述)
わざわざselectしなくても良さそう。
まずは不要なselectを削除してみてどうでしょう。
（寒） 2021/12/28(火) 18:03
また、それを繰り返すくらいなら、いったん全ブックのデータを無条件でまとめてしまい、それから振り分けた方が効率がよかったりしませんか？
（もこな２） 2021/12/28(火) 18:09
Sub test()
Dim dicA As Object, dicB As Object
Dim wsh As Object, p As String, cmd As String, s
Dim i As Long, k As Long
Dim 商品 As String, カテゴリ As String, 地域 As String, 県 As String
Dim キー As String, 回答 As Long
Dim wb As Workbook, ws As Worksheet
Dim myList
Set dicA = CreateObject("scripting.dictionary")
Set dicB = CreateObject("scripting.dictionary")
Set wsh = CreateObject("wscript.shell")
p = ThisWorkbook.Path & "\アンケート回答\"
cmd = "cmd /c dir """ & p & "*A_アンケート*.xlsm"" /b/s"
s = Split(wsh.exec(cmd).stdout.readall, vbCrLf)
For i = 0 To UBound(s) - 1
Set wb = Workbooks.Open(s(i))
For Each ws In wb.Worksheets
If Not ws.Name Like "*【参考】R2年アンケート*" Then
myList = ws.Range("A1", Range("A" & Rows.Count). _
End(xlUp)).Resize(, 4).Value
For k = 2 To UBound(myList)
商品 = myList(k, 1)
カテゴリ = myList(k, 2)
地域 = myList(k, 3)
キー = 商品 & vbTab & カテゴリ & vbTab & 地域
回答 = myList(k, 4)
dicA(キー) = 回答
Next
End If
Next
wb.Close False
Next
cmd = "cmd /c dir """ & p & "*B_アンケート*.xlsm"" /b/s"
s = Split(wsh.exec(cmd).stdout.readall, vbCrLf)
For i = 0 To UBound(s) - 1
Set wb = Workbooks.Open(s(i))
Set ws = wb.Worksheets("B_アンケート結果")
myList = ws.Range("A1", Range("A" & Rows.Count). _
End(xlUp)).Resize(, 2).Value
県 = myList(1, 1)
カテゴリ = myList(1, 2)
For k = 4 To UBound(myList)
商品 = myList(k, 3)
キー = 商品 & vbTab & カテゴリ & vbTab & 県
回答 = myList(k, 2)
dicB(キー) = 回答
Next
wb.Close False
Next
Set ws = ThisWorkbook.Worksheets("アンケート_DB")
myList = ws.Range("A1", Range("A" & Rows.Count). _
End(xlUp)).Resize(, 6).Value
For k = 2 To UBound(myList)
商品 = myList(k, 1)
カテゴリ = myList(k, 2)
地域 = myList(k, 3)
県 = myList(k, 4)
キー = 商品 & vbTab & カテゴリ & vbTab & 地域
If dicA.exists(キー) Then myList(k, 5) = dicA(キー)
キー = 商品 & vbTab & カテゴリ & vbTab & 県
If dicB.exists(キー) Then myList(k, 6) = dicB(キー)
Next
End Sub
（マナ） 2021/12/29(水) 23:48
ws.Range("A1").Resize(UBound(myList, 1), UBound(myList, 2)).Value = myList
（マナ） 2021/12/29(水) 23:57
返信遅れて申し訳ありません。ご意見を参考に全ブックを一枚のシートにまとめてから転記していくマクロを作成しましたが
配列にデータを代入し、収集用のシートに転記すると1-6が4420に変換されてしまいます。変換されないためにはどう書き換えればよいでしょうか？
ちなみに転記用のファイルの書式設定を調べてみましたが、文字列でした。
※下記はコードの一部です。
Sub 複数の条件があうものを抽出()
Application.ScreenUpdating = False Dim DB_Sht As Worksheet, s一覧 As Worksheet, B_sht As Worksheet Dim wb As Workbook Dim ws As Worksheet, dWS As Worksheet, dWS2 As Worksheet Dim MyList() As Variant Dim LastRow As Long, n As Long, i As Long, j As Long Dim sFileName As String
Set s一覧 = Worksheets("一覧")
Set DB_Sht = Worksheets("アンケート_DB")
With s一覧
.Range("A:A").ClearContents
sFileName = Dir(ThisWorkbook.Path & "\アンケート回答\*.xlsm")
i = 1
Do Until sFileName = ""
.Cells(i, 1) = ThisWorkbook.Path & "\アンケート回答\" & sFileName
i = i + 1
sFileName = Dir()
Loop
End With
Set dWS = Sheets.Add(After:=Sheets(Sheets.Count))
dWS.Name = "アンケA集約"
Set dWS2 = Sheets.Add(After:=Sheets(Sheets.Count))
dWS2.Name = "アンケB集約"
For n = 1 To s一覧.Cells(s一覧.Rows.Count, 1).End(xlUp).Row
Set wb = Workbooks.Open(s一覧.Cells(n, 1))
Select Case True
Case InStr(wb.Name, "A_アンケート")
For Each ws In Worksheets
If InStr(ws.Name, "【参考】R2年アンケート") = 0 Then '3シートのうち【参考】R2年アンケートだけ除外
ws.Select
MyList = ws.Range("A2", Range("A" & Rows.Count). _
End(xlUp)).Resize(, 4).Value
LastRow = dWS.Cells(ws.Rows.Count, 1).End(xlUp).Row
With dWS
If dWS.Cells(1, 1) = "" Then
Range(.Cells(1, 1), .Cells(UBound(MyList), 4)) = MyList '最初だけ1行目から貼り付け
Else
Range(.Cells(LastRow + 1, 1), .Cells(LastRow + UBound(MyList), 4)) = MyList '最初以外は最終行の次に貼り付け
End If
End With
End If
Next
Erase MyList
wb.Close SaveChanges:=False
（こば） 2021/12/30(木) 13:32
配列を書き出す範囲に、意図的に書式設定をしておけば良いのでは。 下記例のA1:A5を配列に格納し、B1:B5に書き出す場合
|[A]
[1]|1-6
[2]|1-7
[3]|1-8
[4]|1-9
[5]|1-10
Sub macro()
Dim arr
arr = Range("A1:A5").Value
With Range("B1:B5")
.NumberFormatLocal = "@"
.Value = arr
End With
End Sub
（寒） 2021/12/30(木) 17:59
'------ Power Queryで遊んでみました。
'--------
クエリ名：条件があうものを抽出
let
ソース = Excel.CurrentWorkbook(){[Name="テーブル1"]}[Content],
変更された型 = Table.TransformColumnTypes(ソース,{{"商品名", type text}, {"カテゴリ", type text}, {"地域", type text}, {"県", type text}}),
追加されたインデックス = Table.AddIndexColumn(変更された型, "インデックス", 0, 1, Int64.Type),
マージされたクエリ数 = Table.NestedJoin(追加されたインデックス, {"商品名", "カテゴリ", "地域"}, 回答1, {"商品名", "カテゴリ", "地域"}, "回答1", JoinKind.LeftOuter),
#"展開された 回答1" = Table.ExpandTableColumn(マージされたクエリ数, "回答1", {"回答１"}, {"回答１"}),
マージされたクエリ数1 = Table.NestedJoin(#"展開された 回答1", {"商品名", "カテゴリ", "県"}, 回答2, {"商品名", "カテゴリ", "県"}, "回答2", JoinKind.LeftOuter),
#"展開された 回答2" = Table.ExpandTableColumn(マージされたクエリ数1, "回答2", {"回答2"}, {"回答2"}),
並べ替えられた行 = Table.Sort(#"展開された 回答2",{{"インデックス", Order.Ascending}}),
削除された他の列 = Table.SelectColumns(並べ替えられた行,{"回答１", "回答2"})
in
削除された他の列
'--------
クエリ名；回答1
(接続専用）
let
ソース = Folder.Files("ここにアンケート回答フォルダーのパス"),
フィルターされた行 = Table.SelectRows(ソース, each Text.Contains([Name], "A_アンケート")),
小文字テキスト = Table.TransformColumns(フィルターされた行,{{"Extension", Text.Lower, type text}}),
フィルターされた行1 = Table.SelectRows(小文字テキスト, each [Extension] = ".xlsm"),
追加されたカスタム = Table.AddColumn(フィルターされた行1, "カスタム", each Excel.Workbook(File.Contents([Folder Path] & [Name]))),
#"展開された カスタム" = Table.ExpandTableColumn(追加されたカスタム, "カスタム", {"Data", "Item"}, {"Data", "Item"}),
フィルターされた行2 = Table.SelectRows(#"展開された カスタム", each not Text.Contains([Item], "【参考】R2年アンケート")),
削除された他の列 = Table.SelectColumns(フィルターされた行2,{"Data"}),
#"展開された Data" = Table.ExpandTableColumn(削除された他の列, "Data", {"Column1", "Column2", "Column3", "Column4"}, {"Column1", "Column2", "Column3", "Column4"}),
昇格されたヘッダー数 = Table.PromoteHeaders(#"展開された Data", [PromoteAllScalars=true]),
変更された型 = Table.TransformColumnTypes(昇格されたヘッダー数,{{"商品名", type text}, {"カテゴリ", type text}, {"地域", type text}, {"回答１", type any}}),
フィルターされた行3 = Table.SelectRows(変更された型, each [商品名] <> "商品名")
in
フィルターされた行3
'--------
クエリ名；回答2
(接続専用）
let
ソース = Folder.Files("ここにアンケート回答フォルダーのパス"),
フィルターされた行 = Table.SelectRows(ソース, each Text.Contains([Name], "B_アンケート")),
小文字テキスト = Table.TransformColumns(フィルターされた行,{{"Extension", Text.Lower, type text}}),
フィルターされた行1 = Table.SelectRows(小文字テキスト, each [Extension] = ".xlsm"),
追加されたカスタム = Table.AddColumn(フィルターされた行1, "カスタム", each Excel.Workbook(File.Contents([Folder Path] & [Name]))),
#"展開された カスタム" = Table.ExpandTableColumn(追加されたカスタム, "カスタム", {"Data", "Item"}, {"Data", "Item"}),
フィルターされた行2 = Table.SelectRows(#"展開された カスタム", each [Item] = "B_アンケート結果"),
追加されたカスタム1 = Table.AddColumn(フィルターされた行2, "カスタム", each Table.AddIndexColumn([Data],"index")),
削除された他の列 = Table.SelectColumns(追加されたカスタム1,{"カスタム"}),
#"展開された カスタム1" = Table.ExpandTableColumn(削除された他の列, "カスタム", {"Column1", "Column2", "index"}, {"Column1", "Column2", "index"}),
追加された条件列 = Table.AddColumn(#"展開された カスタム1", "県", each if [index] = 0 then [Column1] else null),
追加された条件列1 = Table.AddColumn(追加された条件列, "カテゴリ", each if [index] = 0 then [Column2] else null),
下方向へコピー済み = Table.FillDown(追加された条件列1,{"県", "カテゴリ"}),
フィルターされた行3 = Table.SelectRows(下方向へコピー済み, each [index] >= 3),
#"名前が変更された列 " = Table.RenameColumns(フィルターされた行3,{{"Column1", "商品名"}, {"Column2", "回答2"}}),
削除された他の列1 = Table.SelectColumns(#"名前が変更された列 ",{"商品名", "カテゴリ", "県", "回答2"})
in
削除された他の列1
（マナ） 2021/12/30(木) 20:10
（こば） 2021/12/31(金) 21:40
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.