[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『複数ファイルからの一括転記 』（aaaccc）
いつも参考にしております。
表題の件なのですが、vbaを活用し、複数（数百）のブックの値を一つのブックに転記したいです。
たとえば、各社員の評価ファイルの評価値を従業員名簿の各社員に対応するセルに一括転記したいです。
具体的には、 ・従業員名簿のa列には固有ID列があり、各社員の評価ファイルのA1にも同様の固有IDが入力されています。 （この固有IDを使って、転記する行を参照したいです） ・各社員の評価ファイルは数百ファイルあるとし、転記したい評価値セルはC4、D4、（全ファイル固定）とします。 ・転記先は従業員名簿のC、D列の各社員に該当するセルにしたいです。 ・従業員名簿ファイルと各社員の評価ファイルは同じフォルダに格納しております。
あくまで、エクセル関数ではなくvbaで実行したいと考えております。
ファイルイメージは以下のようになります。
＜従業員名簿＞ （転記前）
A B C D
１ 加藤
２ 鈴木
３ 佐藤
＜加藤の評価ファイル＞
A1に1、C4にB、D４にCが入力済み
＜従業員名簿＞ （３名のファイル転記後）
A B C D
１ 加藤 B C
２ 鈴木 A A
３ 佐藤 D C
あと、CとD列にすでに値が入力されている場合は、
上書きしますか？はい いいえのチェック画面を出したいです。
（ただ、数百数十のセルにすでに値がある場合、はい、いいえをその数押さないといけないので、
何かほかにスマートな重複チェックはございませんでしょうか？）
以上、よろしくお願いいたします。
＜ 使用 Excel：Excel2013、使用 OS：Windows7 ＞
従業員名簿ブックをマクロブックにしてあります。 マクロブックは別で、従業員名簿ブックも xlsxデータブック ということであれば少し変更します。 従業員名簿シートは "Sheet1" という名前にしてあります。実際の名前に変更してください（★印のところ） また、各社員ブックのシートは最初のシート（一番左側のシート）にしてあります。
すでに値が記入済のものがあった際に都度メッセージを出すのも操作者がいやがるかもしれないので ここは無条件に上書きして、その社員番号セルを赤くしたうえで、最後にメッセージで知らせます。 加えて、各社員ブックの社員番号が従業員名簿ブックになかった場合は、最後に、その旨メッセージを出しています。
書きなぐったので不具合あれば御容赦。
Sub Sample()
Dim nfd As Object
Dim v As Variant
Dim fpath As String
Dim fName As String
Dim shT As Worksheet
Dim shF As Worksheet
Dim f As Range
Dim dup As Range
Application.ScreenUpdating = False
Set nfd = CreateObject("System.Collections.ArrayList")
fpath = ThisWorkbook.Path & "\"
Set shT = ThisWorkbook.Sheets("Sheet1") '★従業員一覧
With shT.Range("A1").CurrentRegion
.Columns(1).Interior.ColorIndex = xlNone
v = .Columns(3).Resize(, 2).Value
fName = Dir(fpath & "*.xlsx")
Do While fName <> ""
Set shF = Workbooks.Open(fpath & fName).Sheets(1)
Set f = .Columns(1).Find(What:=shF.Range("A1").Value, LookAt:=xlWhole)
If Not f Is Nothing Then
If WorksheetFunction.CountA(f.Offset(, 2).Resize(, 2)) <> 0 Then
If dup Is Nothing Then
Set dup = f
Else
Set dup = Union(f, dup)
End If
End If
v(f.Row, 1) = shF.Range("C4").Value
v(f.Row, 2) = shF.Range("D4").Value
Else
nfd.Add shF.Range("A1").Value
End If
shF.Parent.Close False
fName = Dir()
Loop
.Columns(3).Resize(, 2).Value = v
If Not dup Is Nothing Then
dup.Interior.Color = vbRed
End If
End With
Application.ScreenUpdating = True
If nfd.Count > 0 Then MsgBox "以下の番号が一覧表にありませんでした" & vbLf & Join(nfd.toarray, vbLf)
If Not dup Is Nothing Then MsgBox "すでにデータ入力済みの番号がありました。色を付けてあります"
End Sub
（β） 2017/04/04(火) 18:07
MOUGも、ここ、学校もマルチポストは許容していますが、あまり好きじゃないですね。 (コード案アップしてから気が付きました）
（β） 2017/04/04(火) 18:12
＞評価ファイルのA1
シート名は何ですか？ ※評価ファイルにシートは1枚だけしか含まれていない、とかで自明なのですか？
＞あと、CとD列にすでに値が入力されている場合は、 ＞上書きしますか？はい いいえのチェック画面を出したいです。 ＞（ただ、数百数十のセルにすでに値がある場合、はい、 ＞ いいえをその数押さないといけないので、 ＞ 何かほかにスマートな重複チェックはございませんでしょうか？）
「既に値が入っている」=「重複」と言う関係が理解しにくいのですが、
都度、上書きしていいか確認する意味は何ですか？ それによっても対策が変わる様な気がします。
手操作なら勘違いもあるでしょうが、機械処理ですからミスの余地はないです。 それが信頼できなければ、自動化の意義が半減します。
（半平太） 2017/04/04(火) 19:09
ご回答ありがとうございます。
マルチポストの件、申し訳ございませんでした。
向こうは解決済みにしました。
本題なのが、サンプルデータで試したところ、問題なく実行できました。
色づけされたセル（すでに値が入力されているセル）がある行を上書きする前の値で別のシートにコピーすることは可能でしょうか？
あと、厚かましいお願いではございますが当方初心者でございまして、今後の応用のためにも、
各行でどのような処理が行われているかご教示していただけないでしょうか？（もちろん、コードで検索し理解しようとしましたが、わからない部分も多く、理解しきれなかったです）
（aaaccc） 2017/04/05(水) 11:37
とりあえず、上書き分の上書き前の状態を別シートにコピーするところを追加しました。 コードでは コピー先シート名を "Sheet2" としています。
コード説明は、すべての確認が終わってからにしましょう。
Sub Sample2()
Dim nfd As Object
Dim v As Variant
Dim fpath As String
Dim fName As String
Dim shT As Worksheet
Dim shF As Worksheet
Dim shW As Worksheet
Dim f As Range
Dim dup As Range
Dim x As Long
Application.ScreenUpdating = False
Set nfd = CreateObject("System.Collections.ArrayList")
fpath = ThisWorkbook.Path & "\"
Set shT = ThisWorkbook.Sheets("Sheet1") '★従業員一覧
Set shW = ThisWorkbook.Sheets("Sheet2") '★上書きデータリスティングシート
shW.Cells.ClearContents
With shT.Range("A1").CurrentRegion
.Columns(1).Interior.ColorIndex = xlNone
v = .Columns(3).Resize(, 2).Value
fName = Dir(fpath & "*.xlsx")
Do While fName <> ""
Set shF = Workbooks.Open(fpath & fName).Sheets(1)
Set f = .Columns(1).Find(What:=shF.Range("A1").Value, LookAt:=xlWhole)
If Not f Is Nothing Then
If WorksheetFunction.CountA(f.Offset(, 2).Resize(, 2)) <> 0 Then
x = x + 1
f.EntireRow.Copy shW.Cells(x, "A")
If dup Is Nothing Then
Set dup = f
Else
Set dup = Union(f, dup)
End If
End If
v(f.Row, 1) = shF.Range("C4").Value
v(f.Row, 2) = shF.Range("D4").Value
Else
nfd.Add shF.Range("A1").Value
End If
shF.Parent.Close False
fName = Dir()
Loop
.Columns(3).Resize(, 2).Value = v
If Not dup Is Nothing Then
dup.Interior.Color = vbRed
End If
End With
Application.ScreenUpdating = True
If nfd.Count > 0 Then MsgBox "以下の番号が一覧表にありませんでした" & vbLf & Join(nfd.toarray, vbLf)
If Not dup Is Nothing Then MsgBox "すでにデータ入力済みの番号がありました。色を付けてあります"
End Sub
（β） 2017/04/05(水) 23:44
お世話になります。
おんぶに抱っこで申し訳ないです。
ありがとうございます。
以上、よろしくお願いします。
（aaaccc） 2017/04/06(木) 09:48
コードの説明ですが、１行１行、すべて解説しても、かえって煩雑かもしれません。 aaacccさんが、どうしてもわからないコードをピックアップしてもらえませんか。
その部分に対して説明したほうがわかりやすいと思いますので。
（β） 2017/04/06(木) 11:53
お世話になります。
では、下記に記します。
?@Set nfd = CreateObject("System.Collections.ArrayList")
?A v = .Columns(3).Resize(, 2).Value(リサイズのほうはなぜカンマがあるのでしょうか？）
?Bループ処理のところは詳しく解説していただきたいです。
よろしくお願いします。
（aaaccc） 2017/04/06(木) 13:11
なぜでしょうか？
（aaaccc） 2017/04/06(木) 13:42
コード説明は後に回して質問の件。
そちらの各ブックのデータが見えないのでなんともいえないのですが、コードでは上書き前の従業員一覧の 内容と各ブックの内容を比較しています。
ですから 1 加藤（コードでチェックしているのは 1 だけですが）に値がすでに入っていた。 それに対して各ブックの複数のブックに 1 加藤 があった場合は、複数行SHeet2に書きこまれます。
こういった場合も、あくまで １行だけ（最初にあらわれた 1 加藤 の分だけ）Sheet2に記載するということは もちろんできますが。
（ β） 2017/04/06(木) 15:40
お世話になります。
なるほど、そういうことでしたか。
どれくらいのファイルで一括に行えるかテストしたため、A1に１が入力されたファイルを多数配置しておりました。
それならば、β様が記述された処理のほうが好ましいですね。
ありがとうございます。
（aaaccc） 2017/04/06(木) 15:47
コード説明です。
● Set nfd = CreateObject("System.Collections.ArrayList")
ＶＢＡコードは基本的には、ＶＢＡが提供してくれる標準機能を組み合わせて組み立てます。 ただ、ケースによっては、ＶＢＡ以外のプログラムを利用したい場合もでてきます。
・そのプログラムを使わないと実現できない。 ・そのプログラムを使うほうが、よりコード記述がシンプルになる。 ・そのプログラムを使うほうが、処理効率が格段にアップする。
こういったケース。たとえば、よく使われるユーザーフォームもＶＢＡの持ちものではなく 別プログラムです。
で、この別プログラムを呼びだして利用可能にする方法はいくつかあるんですが、最もシンプルなのは
CreateObject("そのプログラムに割り当てられたプログラムＩＤ文字列")
こうして、そのプログラム（オブジェクト）を取得します。
ここでは ArrayList と呼ばれるプログラム（後述）を呼び出しています。
● ArrayList
ArrayList は、きわめてシンプルな構造の、データを複数格納しておける『容器』と そこへの格納、取り出しといった機能を提供してくれるプログラムです。 今回は使っていませんが、格納されたデータを昇順に並び替えたり、さらに降順に並び替えることも可能です。
似たようなプログラムで、キーとデータをペアで格納しておくことができる Dictinary や SortedList といったものもあります。
●v = .Columns(3).Resize(, 2).Value(リサイズのほうはなぜカンマがあるのでしょうか？）
Resize は 元のセル領域.Resize(行数の変更数,列数の変更数) と書きます。 元のサイズと同じでいい場合は省略可能です。
従って Resize(, 2) は 行数としては、元の領域と同じ、列数は 2列に変更 という意味です。 ちなみに、ここで、元の領域は .Columns(3) つまり、A1 から始まる連続したデータ領域全体の３列目。 つまり、C1:C● になっていますので、Resize結果は C1:D● になります。
●ループ処理
ここで使っているループ処理は、フォルダからファイル名を抽出する DIR関数によるループ処理の定番コードです。 DIR関数に対して フォルダパスを含むファイルフルパス（ワイルドカード指定可能）を与えると、該当のファイル名を 返してくれます。
fName = Dir(fpath & "*.xlsx")
最初に与えているのはフォルダ文字列と *.xlsx。 * がワイルドカードで、フォルダ内の xlsx ブックを抽出という意味です。
Do While fName <> ""
DIR関数の結果が空白になれば、もうファイルはない ということになり、繰り返し処理を終了します。 ここでは 空白ではなかったら、つまり ファイルが存在すれば という判定をしています。 で、ファイルがあった場合、 Fname にブック名が入っていますので、それにフォルダパスを加えて ブックを開き 必要な処理を行い、ブックを閉じます。
で、引き続き fName = Dir() 。 ２回目以降の DIR に対しては引数を省略します。 最初の条件と同じ条件で次のブックを取得しなさいという意味になります。
取得後、Loop で繰り返し処理をします。
★繰り返しの構造は、こういったものです。 その繰り返し処理の中では、今回の要件に合わせた処理ロジックがかかれています。 ここについても説明が必要であれば、追加しますけど。
（β） 2017/04/06(木) 22:22
繰り返し内の処理も含めたコード説明なんですが、アップ済みのものは 処理効率等を考慮して、ArrayListを利用したり、書き込みをセルごとではなく配列にすべてを収めたうえで 一括書きこみをしたり、色塗りセルについても、セル毎ではなく必要領域をUNION結合させておいて 最後に一括色塗りといったように「少し工夫」しています。
ただ、もし、aaacccさんが、そのあたりに詳しくなければ、それを踏まえての説明だと、かえって 謎（？）が深まる恐れがあります。
以下はアップ済みのものと同じ処理ですが、『工夫をせず』淡々とセル毎に書きこんでいます。 このコードなら、aaacccさんも、一生懸命追いかければ理解できるかもしれません。
もし、理解できれば、アップ済みのものと同じ処理なので、アップ済みのコードの説明そのものになるのではないかと。
Sub Sample3()
Dim nfd As String
Dim fpath As String
Dim fName As String
Dim shT As Worksheet
Dim shF As Worksheet
Dim shW As Worksheet
Dim f As Range
Dim dup As Boolean
Dim x As Long
Dim mx As Long
Application.ScreenUpdating = False
fpath = ThisWorkbook.Path & "\"
Set shT = ThisWorkbook.Sheets("Sheet1") '★従業員一覧
Set shW = ThisWorkbook.Sheets("Sheet2") '★上書きデータリスティングシート
shW.Cells.ClearContents
mx = shT.Range("A" & Rows.Count).End(xlUp).Row '従業員一覧のA列データ最終セルの行番号
shT.Range("A1:A" & mx).Interior.ColorIndex = xlNone '処理前にA列の背景色を取り除く
fName = Dir(fpath & "*.xlsx")
Do While fName <> ""
Set shF = Workbooks.Open(fpath & fName).Sheets(1)
Set f = shT.Range("A1:A" & mx).Find(What:=shF.Range("A1").Value, LookAt:=xlWhole)
If Not f Is Nothing Then
If WorksheetFunction.CountA(f.Offset(, 2).Resize(, 2)) <> 0 Then
x = x + 1
f.EntireRow.Copy shW.Cells(x, "A")
f.Interior.Color = vbRed
dup = True
End If
f.Offset(, 2).Value = shF.Range("C4").Value
f.Offset(, 3).Value = shF.Range("D4").Value
Else
nfd = nfd & vbLf & shF.Range("A1").Value
End If
shF.Parent.Close False
fName = Dir()
Loop
Application.ScreenUpdating = True
If nfd <> "" Then MsgBox "以下の番号が一覧表にありませんでした" & vbLf & Mid(nfd, 2)
If dup Then MsgBox "すでにデータ入力済みの番号がありました。色を付けてあります"
End Sub
（β） 2017/04/07(金) 18:00
お世話になります。
レスポンスが遅くなり申し訳ございません。
まだ、確認できておりませんが、後述のコードのほうもしっかり理解したいと思います。
お気遣いありがとうございます。
ところで、疑問に思ったのですが、
この例では、評価ファイルのC4、D４の値を従業員名簿のC、D列の対応するセルに入力しています。
今後この例で言う従業員名簿は列が追加削除される可能性があります(行はもちろん追加削除します）。
そこで問題になりそうなのが、たとえば従業員名簿のB列（名前列）の次に年収列を新たに追加するとしたら、年収列に評価値が転記されてしまいますよね？
こういった列の追加削除に柔軟に対応（できれば、ユーザーが何もせずとも列の追加削除に対応）することは可能なのでしょうか？
評価ファイルはおそらく今後も変更はないと思います。
追加の質問になり申し訳ないですが、よろしくお願いいたします。
（aaaccc） 2017/04/10(月) 11:14
列関連のレイアウトが変更されても 評価ファイルの所定のセルの値を、変更後の列の位置に正しく反映するためには 方法は ２つしかないです。
１．変更された列にあわせて、コードを変更する。 ２．現在は、１行目からデータになっているようですが、通常は、１行目にはタイトル行を設けるのが エクセルによるデータ管理の鉄則です。 で、たとえば、現在の Ｃ列 のタイトルとして "評価1" 、Ｄ列のタイトルとして "評価2" といったものをセットしておく。 そうしておけば、列が挿入されたり、あるいはまた削除されたりして、列の位置が変更になっても、マクロ内で １行目の "評価1" や "評価2" といった文字列を Findメソッドなり MATCH関数なりで検索し、ヒットした列が それぞれの値を転記すべき列だと、そう判定することができますので。
（β） 2017/04/10(月) 11:30
さっそくのご返信ありがとございます。
２の方法に関してなのですが、
実際のデータでは１行目はタイトルとして管理しております。
Findメソッドに関して試行錯誤してみようと思います。
ありがとうございます。
（aaaccc） 2017/04/10(月) 11:39
参考コードをアップしておきます。 ★★ のとことは実際のタイトルに変更してください。
Sub Sample4()
Const WD1 As String = "評価1" '★★実際のタイトル文字列に
Const WD2 As String = "評価2" '★★実際のタイトル文字列に
Dim wd As Variant
Dim n As Long
Dim col(1 To 2) As Long
Dim nfd As Object
Dim v1 As Variant
Dim v2 As Variant
Dim fpath As String
Dim fName As String
Dim shT As Worksheet
Dim shF As Worksheet
Dim shW As Worksheet
Dim f As Range
Dim dup As Range
Dim x As Long
Application.ScreenUpdating = False
Set nfd = CreateObject("System.Collections.ArrayList")
fpath = ThisWorkbook.Path & "\"
Set shT = ThisWorkbook.Sheets("Sheet1") '★従業員一覧
Set shW = ThisWorkbook.Sheets("Sheet2") '★上書きデータリスティングシート
shW.Cells.ClearContents
For n = 1 To 2
Set f = shT.Rows(1).Find(What:=Array(WD1, WD2)(n - 1), LookAt:=xlWhole)
If f Is Nothing Then
MsgBox Array(WD1, WD2)(n - 1) & " のタイトルがありません。管理者に連絡してください"
Exit Sub
End If
col(n) = f.Column
Next
With shT.Range("A1").CurrentRegion
.Columns(1).Interior.ColorIndex = xlNone
v1 = .Columns(col(1)).Value
v2 = .Columns(col(2)).Value
fName = Dir(fpath & "*.xlsx")
Do While fName <> ""
Set shF = Workbooks.Open(fpath & fName).Sheets(1)
Set f = .Columns(1).Find(What:=shF.Range("A1").Value, LookAt:=xlWhole)
If Not f Is Nothing Then
If WorksheetFunction.CountA(f.EntireRow.Columns(col(1)), f.EntireRow.Columns(col(2))) <> 0 Then
x = x + 1
f.EntireRow.Copy shW.Cells(x, "A")
If dup Is Nothing Then
Set dup = f
Else
Set dup = Union(f, dup)
End If
End If
v1(f.Row, 1) = shF.Range("C4").Value
v2(f.Row, 1) = shF.Range("D4").Value
Else
nfd.Add shF.Range("A1").Value
End If
shF.Parent.Close False
fName = Dir()
Loop
.Columns(col(1)).Value = v1
.Columns(col(2)).Value = v2
If Not dup Is Nothing Then
dup.Interior.Color = vbRed
End If
End With
Application.ScreenUpdating = True
If nfd.Count > 0 Then MsgBox "以下の番号が一覧表にありませんでした" & vbLf & Join(nfd.toarray, vbLf)
If Not dup Is Nothing Then MsgBox "すでにデータ入力済みの番号がありました。色を付けてあります"
End Sub
（β） 2017/04/10(月) 11:56
ご返信ありがとうございます。
記述していただいたコードは問題なく、動作しております。ありがとうざいます。
findメソッドの部分をコードにどのように組み込みのかというところで悩んでおりました。
なるほどという感じです。こういう記述になるというイメージすらできておりませんでした。
にらめっこして理解していきたいと思います。
また、疑問点が出たのですが、現在は上記のような例のサンプルデータでテストしているのですが、
実際に転記先として考えているエクセルファイルは多数の列がございます。
そのファイルにコードを適応するに当たって、変更するべき箇所をリストアップしてみたのですが、間違い漏れはないか教えていただけないでしょうか？
Const WD1 As String = "評価1" '★★実際のタイトル文字列に の列名
Const WD2 As String = "評価2" '★★実際のタイトル文字列に の列名
Dim col(1 To 2) As Long ここの1 To 2部分は変更する必要がありますか？
For n = 1 To 2 ここも変更する必要がありますか？
よろしくお願いします。
（aaaccc） 2017/04/10(月) 13:45
該当の列がどこにあろうと、２列だけを相手にするということであれば、★★のところを 実際のタイトル文字列にするだけでＯＫです。
そのほかは一切変更不要です。
（ β） 2017/04/10(月) 17:04
ご返信ありがとうございます。
では、３箇所を転記する場合は
Const WD1 As String = "評価1" '★★実際のタイトル文字列に の列名
Const WD2 As String = "評価2" '★★実際のタイトル文字列に の列名
にwd3を追加
For n = 1 To 2 の 2を3にする
Set f = shT.Rows(1).Find(What:=Array(WD1, WD2)(n - 1), LookAt:=xlWhole) If f Is Nothing Then MsgBox Array(WD1, WD2)(n - 1) & " のタイトルがありません。管理者に連絡してください"
を
Set f = shT.Rows(1).Find(What:=Array(WD1, WD2,WD3)(n - 1), LookAt:=xlWhole) If f Is Nothing Then MsgBox Array(WD1, WD2,WD3)(n - 1) & " のタイトルがありません。管理者に連絡してください" に変更。
v1 = .Columns(col(1)).Value
v2 = .Columns(col(2)).Value
の次に
v3 = .Columns(col(3)).Valueを追加。
If Not f Is Nothing Then
If WorksheetFunction.CountA(f.EntireRow.Columns(col(1)), f.EntireRow.Columns(col(2))) <> 0 Then
x = x + 1
f.EntireRow.Copy shW.Cells(x, "A")
If dup Is Nothing Then
Set dup = f
Else
Set dup = Union(f, dup)
End If
End If
v1(f.Row, 1) = shF.Range("C4").Value
v2(f.Row, 1) = shF.Range("D4").Value
Else
nfd.Add shF.Range("A1").Value
End If
shF.Parent.Close False
fName = Dir()
Loop
.Columns(col(1)).Value = v1
.Columns(col(2)).Value = v2
If Not dup Is Nothing Then
dup.Interior.Color = vbRed
End If
End With
の部分を
If Not f Is Nothing Then
If WorksheetFunction.CountA(f.EntireRow.Columns(col(1)), f.EntireRow.Columns(col(2)) f.EntireRow.Columns(col(3))) <> 0 Then
x = x + 1
f.EntireRow.Copy shW.Cells(x, "A")
If dup Is Nothing Then
Set dup = f
Else
Set dup = Union(f, dup)
End If
End If
v1(f.Row, 1) = shF.Range("C4").Value
v2(f.Row, 1) = shF.Range("D4").Value
v3(f.Row, 1) = shF.Range("E4").Value （転記引用元がE4として）
Else
nfd.Add shF.Range("A1").Value
End If
shF.Parent.Close False
fName = Dir()
Loop
.Columns(col(1)).Value = v1
.Columns(col(2)).Value = v2
.Columns(col(3)).Value = v3
If Not dup Is Nothing Then
dup.Interior.Color = vbRed
End If
End With
で問題ないでしょうか?(今からテストします）
よろしくお願いします。
（aaaccc） 2017/04/11(火) 09:29
Dim col(1 To 2) As Long
ここも増やしておきましょうね。 もちろん Dim v3 As Varant も追加しておきましょう。
今後、対象の列が さらに増える（つまり、参照元ブックの参照セルも増える）可能性もありますね。 もちろん、今回、追加されたような要領で対応していってもらえればいいのですが、これらについても 最初のほうで定義しておくことで、処理ロジックについては、コード変更なしのものにすることは可能です。
興味があればそれも書いてもいいですけど、いかがですか。
（ β） 2017/04/11(火) 10:29
お世話になります。
ご指摘ありがとうございます。
お気遣いありがとうございます。
そうですね、やはり柔軟に対応できるほうが好ましいので、お願いしてもよろしいでしょうか？
あと、実際のデータでは
この例で言うと、評価ファイルは同じなのですが、
従業員名簿のほうは、列名を記入してあるのが8行目（1～７は別のデータで関係ないデータや空白セル）で共通id列が4列目、転記先列は評価１が166列目、評価２が167列目です。
で、βさま に記述していただいたコードを変更し、実行しているのですが、転記されません。
どこが間違っているのでしょうか？
Sub Sample3()
Dim nfd As String
Dim fpath As String
Dim fName As String
Dim shT As Worksheet
Dim shF As Worksheet
Dim shW As Worksheet
Dim f As Range
Dim dup As Boolean
Dim x As Long
Dim mx As Long
Application.ScreenUpdating = False
fpath = ThisWorkbook.Path & "\"
Set shT = ThisWorkbook.Sheets("sheet1") '★従業員一覧
Set shW = ThisWorkbook.Sheets("Sheet2") '★上書きデータリスティングシート
shW.Cells.ClearContents
mx = shT.Range("D" & Rows.Count).End(xlUp).Row '従業員一覧のA列データ最終セルの行番号
shT.Range("D10:D" & mx).Interior.ColorIndex = xlNone '処理前にA列の背景色を取り除く
fName = Dir(fpath & "*.xlsx")
Do While fName <> ""
Set shF = Workbooks.Open(fpath & fName).Sheets(1)
Set f = shT.Range("D1:D" & mx).Find(What:=shF.Range("A1").Value, LookAt:=xlWhole)
If Not f Is Nothing Then
If WorksheetFunction.CountA(f.Offset(, 2).Resize(, 2)) <> 0 Then
x = x + 1
f.EntireRow.Copy shW.Cells(x, "A")
f.Interior.Color = vbRed
dup = True
End If
f.Offset(, 2).Value = shF.Range("C4").Value
f.Offset(, 3).Value = shF.Range("D4").Value
Else
nfd = nfd & vbLf & shF.Range("A1").Value
End If
shF.Parent.Close False
fName = Dir()
Loop
Application.ScreenUpdating = True
If nfd <> "" Then MsgBox "以下の番号が一覧表にありませんでした" & vbLf & Mid(nfd, 2)
If dup Then MsgBox "すでにデータ入力済みの番号がありました。色を付けてあります"
End Sub
（aaaccc） 2017/04/11(火) 11:49
２列限定、かつ連続した２列 というものを相手にするバージョンですね。
If WorksheetFunction.CountA(f.Offset(, 2).Resize(, 2)) <> 0 Then
これを
If WorksheetFunction.CountA(f.EntireRow.Columns("FJ:FK")) <> 0 Then
に直してください。また。
f.Offset(, 2).Value = shF.Range("C4").Value
f.Offset(, 3).Value = shF.Range("D4").Value
これを
f.EntireRow.Columns("FJ").Value = shF.Range("C4").Value
f.EntireRow.Columns("FK").Value = shF.Range("D4").Value
に直してください。
★様々な要件をコードの先頭で規定し、そこを直すだけで、レイアウト変更に対応するコードですが ArrayList 等を使った 『工夫バージョン』、あるいは 標準コードのみを使った『工夫無バージョン』の いずれがいいですか？
（β） 2017/04/11(火) 16:19
お世話になります。
さっそくのご返信ありがとうございます。
２列限定、かつ連続した２列
ではなくたとえば３列（もしくはそれ以上）で連続していない（たとえばP列とFJ列FK列の場合など）はどうすればよいのでしょうか？（おそらくこのパターンになりそうなので）
「★様々な要件をコードの先頭で規定し、そこを直すだけで、レイアウト変更に対応するコードですが ArrayList 等を使った 『工夫バージョン』、あるいは 標準コードのみを使った『工夫無バージョン』の いずれがいいですか？」 とのことですが、標準コードのみを使った『工夫無バージョン』でお願いします(処理速度はかなり違いますかね？）
あと、いろいろ試していて気づいたのが、現在は固有ID列(数値）で一致する行を探していると思うのですが、A1が文字の場合（2とかではなくtt23）の場合だとうまくいかないのですが、文字列で突合させるのは無理なのでしょうか？
質問ばかりで申しわけございませんが、よろしくお願いいたします。
以上、よろしくお願いします。
（aaaccc） 2017/04/11(火) 16:42
それでは、今までアップしたコードはすべて忘れてください。 今から書いてみますので、しばしお待ちを。
ところで、
>A1が文字の場合（2とかではなくtt23）の場合だとうまくいかないのですが、文字列で突合させるのは無理なのでしょうか？
そんなことはないですよ。 よくあるのが 評価ブック側が tt23の後ろにスペースがあり、従業員一覧のほうは 正しく入っているとか その逆とか。 （スペースじゃなく、別の媒体からコピペした場合に、ケースによってはついてしまう目に見えないゴミもありえます。)
>処理速度はかなり違いますかね？
確実に遅くなりますけど、まぁ、それが耐えられる範囲か、耐えられない範囲かは、aaacccさんの判断次第です。
（β） 2017/04/11(火) 17:24
とりあえず書きました。 コードの上のほう、レイアウト既定部分を、実際のシート要件にあわせて変更すれば、あとはコード変更不要です。 変動する規定情報をもとにした処理ですからコードがますますわかりにくくなっているかもしれません。
Sub Test()
Dim aryT As Variant
Dim aryA As Variant
Dim tLine As Long
Dim cols As Long
Dim col As Variant
Dim vLines As Long
Dim idCol As Long
Dim n As Long
Dim w As Variant
Dim f As Range
Dim idR As Range
Dim colAdr As String
Dim nfd As String
Dim fpath As String
Dim fName As String
Dim shT As Worksheet
Dim shF As Worksheet
Dim shW As Worksheet
Dim dup As Boolean
Dim x As Long
Dim mx As Long
Application.ScreenUpdating = False
'=============== レイアウト規定 =================================================================
aryT = Array("評価1", "評価2", "評価3") '従業員一覧の転記必要タイトル 必要なだけいくつでも
aryA = Array("C4", "D4", "E4") '転記元のセルを タイトル順にあわせて、同じ数だけ
tLine = 8 '従業員一覧のタイトル行番号
idCol = 4 '従業員一覧のＩＤ列の列番号
'================================================================================================
fpath = ThisWorkbook.Path & "\"
Set shT = ThisWorkbook.Sheets("sheet1") '★従業員一覧
Set shW = ThisWorkbook.Sheets("Sheet2") '★上書きデータリスティングシート
shW.Cells.ClearContents
cols = UBound(aryT) + 1 '処理対象列数
mx = shT.Range("D" & Rows.Count).End(xlUp).Row '従業員一覧のA列データ最終セルの行番号
vLines = mx - tLine '転記すべき領域の行数
With Range(shT.Cells(9, idCol), shT.Cells(mx, idCol))
.Interior.ColorIndex = xlNone '処理前にＩＤ列の背景色を取り除く
Set idR = .Cells 'ＩＤ領域
End With
ReDim col(1 To cols)
ReDim colA(1 To cols)
For n = 1 To cols
Set f = shT.Rows(tLine).Find(What:=aryT(n - 1), LookAt:=xlWhole)
If f Is Nothing Then
MsgBox "従業員一覧に " & aryT(n - 1) & "のタイトルがありません" & vbLf & "管理者に連絡してください"
Exit Sub
End If
col(n) = Columns(f.Column).Address
Next
colAdr = Join(col, ",")
fName = Dir(fpath & "*.xlsx")
Do While fName <> ""
Set shF = Workbooks.Open(fpath & fName).Sheets(1)
Set f = idR.Find(What:=shF.Range("A1").Value, LookAt:=xlWhole)
If Not f Is Nothing Then
If WorksheetFunction.CountA(Intersect(f.EntireRow, shT.Range(colAdr))) <> 0 Then
x = x + 1
f.EntireRow.Copy shW.Cells(x, "A")
f.Interior.Color = vbRed
dup = True
End If
For n = 1 To cols
Intersect(f.EntireRow, shT.Range(col(n))).Value = shF.Range(aryA(n - 1)).Value
Next
Else
nfd = nfd & vbLf & shF.Range("A1").Value
End If
shF.Parent.Close False
fName = Dir()
Loop
Application.ScreenUpdating = True
If nfd <> "" Then MsgBox "以下の番号が一覧表にありませんでした" & vbLf & Mid(nfd, 2)
If dup Then MsgBox "すでにデータ入力済みの番号がありました。色を付けてあります"
End Sub
（β） 2017/04/11(火) 19:49
お世話になります。
「今から書いてみますので、しばしお待ちを。」とのことですが、
お手数をおかけし、申し訳ございません。
最初から実際のデータと同じ形式で説明するべきでした。
[>A1が文字の場合（2とかではなくtt23）の場合だとうまくいかないのですが、]
上記件について、もしかしてなのですが、
id列が数式で入力されている場合（=A1＋B1）などの場合だとうまくいかないのですかね？関係ありますかね？
あと、上記コードですが、
変更する箇所が少ないので、私以外のほかの人が変更する場合にも簡単に変更でき、すばらしいと思いました。
本当にありがとうございます。
追ってコードを理解していきたいと思います。
以上、よろしくお願いします。
（aaaccc） 2017/04/12(水) 09:28
お世話になります。
続けて失礼します。
今回は同じパスにある、エクセルから一括転記するというプログラムでしたが、
たとえば、同じブック内でシート名がsheet3のシートからa1（id）を参照し、"C4", "D4", "E4を転記する場合は、
fName = Dir(fpath & "*.xlsx")を消し、
Set f = idR.Find(What:=sheet3.Range("A1").Value, LookAt:=xlWhole)にするだけではダメですよね？（というか試してみます）。
よろしくお願いします。
（aaaccc） 2017/04/12(水) 10:13
>id列が数式で入力されている場合
FIndメソッドの ( ) 内の引数、What: と LookAt: しか指定しませんでしたが、数式がありうるということなら LookIn:=xlValues を追加して試してもらえますか。
>というか試してみます
はい。試してください。（ほかにも消さなければいけないところがありますが、汗をかくのもいいことだと思いますので）
●ところで、
Sheet3.Range("A1").Value
これは、たしかに Sheet3 の A1 という意味なんですが・・・・・
いろいろいうと混乱させるかもしれませんので、あえてふれませんが、ここは
Sheets("Sheet3").Range("A1").Value としたほうが安全です。
（β） 2017/04/12(水) 13:07
お世話になります。
LookIn:=xlValues を追加したところうまくいきました。 あと、重複があった場合、上書きシートに上書き前のデータをコピペすると思うのですが、 その際８行目（列名）も一緒にA行にコピーすることは可能でしょうか？ 下記のように shT.Rows(8).Copyを追加したのですが、うまくいきませんでした。
Do While fName <> ""
Set shF = Workbooks.Open(fpath & fName).Sheets(1)
Set f = idR.Find(What:=shF.Range("A1").Value, LookAt:=xlWhole)
If Not f Is Nothing Then
If WorksheetFunction.CountA(Intersect(f.EntireRow, shT.Range(colAdr))) <> 0 Then
shT.Rows(8).Copy
x = x + 1
f.EntireRow.Copy shW.Cells(x, "A")
f.Interior.Color = vbRed
dup = True
End If
For n = 1 To cols
Intersect(f.EntireRow, shT.Range(col(n))).Value = shF.Range(aryA(n - 1)).Value
Next
よろしくお願いします。
（aaaccc） 2017/04/12(水) 15:23
Sheet2のシートの１行目に Sheet1 のタイトル行を表示したいということですか？
であれば、最後にアップした Test でいいますと、
最初のほうの shW.Cells.ClearContents の下に
shT.Rows(8).Copy shW.Range("A1") を追加。
また、colAdr = Join(col, ",") の下に
x = 1 を追加してください。
ところで、Test ですけど、最初、使う予定があった変数で、結局使わなかったものが、そのまま残っています。 まぎらわしいので
Dim vLines As Long と vLines = mx - tLine '転記すべき領域の行数
この２つを消しておいてください。
（β） 2017/04/12(水) 15:47
お世話になります。
うまくいきました。
シート間の転記についてなのですが、
何件か前のレスポンスで。
「同じブック内でシート名がsheet3のシートからa1（id）を参照し、"C4", "D4", "E4を転記する場合は、」
といってたのですが、勘違いしておりまして、
sheet3の転記したい列は決まっているのですが、行番号が４固定ではなく何行目か決まっておりません。
下記で、sheet3からC,D列をsheet1に転記のイメージを書きます。
＜従業員名簿＞ （転記前）
sheet1
A B C D
１ 加藤
２ 鈴木 ３ 佐藤 sheet3 A B C D 3 佐藤 A C 1 加藤 E E 2 鈴木 B B
＜従業員名簿＞ （転記後）
sheet1
A B C D
１ 加藤 E E ２ 鈴木 B B ３ 佐藤 A C
みたいな感じです。
sheet1と３で共通のidはあるのですが、順番は同じとは限らないという条件です。
この場合もマクロによる転記は可能なのでしょうか？
よろしくいお願いします。
（aaaccc） 2017/04/12(水) 16:45
はい、可能ですよ。
確認します。 今までは 別フォルダの評価ブックのシートから、従業員名簿に転記していたわけですけど 今回は "Sheet3" の、これも一覧になっている、そのリストから ＩＤ なのか 名前なのかわかりませんけど それがマッチする行に転記したいということですね。
後出しで、コードを再作成するのはつかれるので、以下の点、明確にしてください。
１．Sheet1 と Sheet3 のレイアウトは、全く同じですか？ タイトル行の位置とか、セットすべき項目（列）の位置とか。 ２．あるいは、それぞれ、タイトル行の行番号も異なる、ＩＤ（名前？）列の列も異なる、転記したい評価項目の列も異なる？
いずれでもできますが、明確にしてくださいね。
●ただし、２．だと、それなりにコードは複雑になります。
★現在のバージョンがすでに、従業員一覧の順番は、必ずしも フォルダ内のブックの順番ではないですよね。 各評価ブックのＩＤを 従業員一覧の ＩＤ列でFind検索して、書きこむべき行を取得していますよね。
ですから、アップしたコードを理解いただければ、あとは フォルダ内のブックをループで取り出しているところを SHeet3 の各行をループで取り出して処理するようにすれば、それでいいんですが・・・・
（β） 2017/04/12(水) 17:06
上記とは別に アップ済みの Test ですが、このパターンも、これから継続して使うのかもしれません。 コードを見直していて間違いがありましたので以下連絡します。
まず、（β） 2017/04/12(水) 15:47 で連絡した追加コードの内、
shT.Rows(8).Copy shW.Range("A1")
これは
shT.Rows(tLine).Copy shW.Range("A1")
が正しかったです。
くわえて、以下。
mx = shT.Range("D" & Rows.Count).End(xlUp).Row '従業員一覧のA列データ最終セルの行番号
これは
mx = shT.Cells(Rows.Count, idCol).End(xlUp).Row '従業員一覧のA列データ最終セルの行番号
に変更。また、
With Range(shT.Cells(9, idCol), shT.Cells(mx, idCol))
これは
With Range(shT.Cells(tLine + 1, idCol), shT.Cells(mx, idCol))
に変更。
（β） 2017/04/12(水) 20:18
明日は、終日時間が取れないかもしれませんので見切り発車。
最初のほうのレイアウト規定部分、少し設定内容を変えました。 実際のものに変えてください。
従業員一覧シート、転記元シート、それぞれ 対象の列や タイトル行の行番号は 同じでなくてもＯＫ。 ただし、対象列の項目名は同じというしばりです。
Sheet3 から転記しようとして SHeet1 になかったものには SHeet3 側のＩＤセルに色塗り を追加してあります。 後は、今までのものと同じ仕様です。
Sub Test2()
Dim aryT As Variant
Dim tLineT As Long
Dim tLineF As Long
Dim cols As Long
Dim colT As Variant
Dim colF As Variant
Dim idColT As Long
Dim idColF As Long
Dim n As Long
Dim w As Variant
Dim f As Range
Dim idRT As Range
Dim idRF As Range
Dim c As Range
Dim colAdr As String
Dim nfd As String
Dim shT As Worksheet
Dim shF As Worksheet
Dim shW As Worksheet
Dim dup As Boolean
Dim x As Long
Application.ScreenUpdating = False
'=============== レイアウト規定 =================================================================
aryT = Array("評価1", "評価2", "評価3") '従業員一覧と転記元シートの転記必要タイトル 必要なだけいくつでも
tLineT = 8 '従業員一覧のタイトル行番号
tLineF = 12 '転記元シートのタイトル行番号
idColT = 4 '従業員一覧のＩＤ列の列番号
idColF = 2 '転記元シートのＩＤ列の列番号
'================================================================================================
Set shT = ThisWorkbook.Sheets("sheet1") '★従業員一覧
Set shW = ThisWorkbook.Sheets("Sheet2") '★上書きデータリスティングシート
Set shF = ThisWorkbook.Sheets("Sheet3") '★転記元シート
shW.Cells.ClearContents
shT.Rows(tLineT).Copy shW.Range("A1")
cols = UBound(aryT) + 1 '処理対象列数
'従業員一覧 ＩＤ領域
Set idRT = Range(shT.Cells(tLineT + 1, idColT), shT.Columns(idColT).Find(What:="*", LookAt:=xlWhole, LookIn:=xlValues, SearchDirection:=xlPrevious))
'転記元 ＩＤ領域
Set idRF = Range(shF.Cells(tLineF + 1, idColF), shF.Columns(idColF).Find(What:="*", LookAt:=xlWhole, LookIn:=xlValues, SearchDirection:=xlPrevious))
idRT.Interior.ColorIndex = xlNone '処理前に従業員一覧ＩＤ列の背景色を取り除く
idRF.Interior.ColorIndex = xlNone '処理前に転記元シートＩＤ列の背景色を取り除く
ReDim colT(1 To cols)
ReDim colF(1 To cols)
For n = 1 To cols
Set f = shT.Rows(tLineT).Find(What:=aryT(n - 1), LookAt:=xlWhole)
If f Is Nothing Then
MsgBox "従業員一覧に " & aryT(n - 1) & "のタイトルがありません" & vbLf & "管理者に連絡してください"
Exit Sub
End If
colT(n) = Columns(f.Column).Address
Next
For n = 1 To cols
Set f = shF.Rows(tLineF).Find(What:=aryT(n - 1), LookAt:=xlWhole)
If f Is Nothing Then
MsgBox "転記元シートに " & aryT(n - 1) & "のタイトルがありません" & vbLf & "管理者に連絡してください"
Exit Sub
End If
colF(n) = Columns(f.Column).Address
Next
colAdr = Join(colT, ",")
x = 1
For Each c In idRF
Set f = idRT.Find(What:=c.Value, LookAt:=xlWhole, LookIn:=xlValues)
If Not f Is Nothing Then
If WorksheetFunction.CountA(Intersect(f.EntireRow, shT.Range(colAdr))) <> 0 Then
x = x + 1
f.EntireRow.Copy shW.Cells(x, "A")
f.Interior.Color = vbRed
dup = True
End If
For n = 1 To cols
f.EntireRow.Columns(colT(n)).Value = c.EntireRow.Columns(colF(n)).Value
Next
Else
nfd = nfd & vbLf & c.Value
c.Interior.Color = vbRed
End If
Next
Application.ScreenUpdating = True
If nfd <> "" Then MsgBox "以下の番号が一覧表にありませんでした。色を付けてあります" & vbLf & Mid(nfd, 2)
If dup Then MsgBox "すでにデータ入力済みの番号がありました。色を付けてあります"
End Sub
（β） 2017/04/12(水) 21:27
お世話になります。
シート間転記のほうも記述していただき、ありがとうございます。
追って理解してしたいと思います。
（β）2017/04/12(水) 20:18 のご指摘いただいた箇所を修正し、実行したところ、
すでにデータがある場合にidを赤に塗りつぶしsheet2にコピペし、メッセージボックスを出すという処理が行われなくなりました
（シート２の１行目に列名はコピーされるのですが、重複データはコピーされないという状況です。
自分で修正できたら、報告したいと思います。
お忙しいと思いますが、時間があるときにでもよろしくお願いします。
以下が現在のコードです。（シート名とメッセージボックスの文言を変えております）
Sub Test()
Dim aryT As Variant
Dim aryA As Variant
Dim tLine As Long
Dim cols As Long
Dim col As Variant
Dim idCol As Long
Dim n As Long
Dim w As Variant
Dim f As Range
Dim idR As Range
Dim colAdr As String
Dim nfd As String
Dim fpath As String
Dim fName As String
Dim shT As Worksheet
Dim shF As Worksheet
Dim shW As Worksheet
Dim dup As Boolean
Dim x As Long
Dim mx As Long
Application.ScreenUpdating = False
'=============== レイアウト規定 =================================================================
aryT = Array("評価1", "評価2") '従業員一覧の転記必要タイトル 必要なだけいくつでも
aryA = Array("C4", "D4") '転記元のセルを タイトル順にあわせて、同じ数だけ
tLine = 7 '従業員一覧のタイトル行番号
idCol = 4 '従業員一覧のＩＤ列の列番号
'================================================================================================
fpath = ThisWorkbook.Path & "\"
Set shT = ThisWorkbook.Sheets("マスター") '★従業員一覧
Set shW = ThisWorkbook.Sheets("Sheet2") '★上書きデータリスティングシート
shW.Cells.ClearContents
shT.Rows(tLine).Copy shW.Range("A1")
cols = UBound(aryT) + 1 '処理対象列数
mx = shT.Cells(Rows.Count, idCol).End(xlUp).Row '従業員一覧のD列データ最終セルの行番号
With Range(shT.Cells(tLine + 1, idCol), shT.Cells(mx, idCol))
.Interior.ColorIndex = xlNone '処理前にＩＤ列の背景色を取り除く
Set idR = .Cells 'ＩＤ領域
End With
ReDim col(1 To cols)
ReDim colA(1 To cols)
For n = 1 To cols
Set f = shT.Rows(tLine).Find(What:=aryT(n - 1), LookAt:=xlWhole, LookIn:=xlValues)
If f Is Nothing Then
MsgBox "マスターに " & aryT(n - 1) & "という列がありません" & vbLf
Exit Sub
End If
col(n) = Columns(f.Column).Address
Next
colAdr = Join(col, ",")
x = 1
fName = Dir(fpath & "*.xlsx")
Do While fName <> ""
Set shF = Workbooks.Open(fpath & fName).Sheets(1)
Set f = idR.Find(What:=shF.Range("A1").Value, LookAt:=xlWhole, LookIn:=xlValues)
If Not f Is Nothing Then
If WorksheetFunction.CountA(Intersect(f.EntireRow, shT.Range(colAdr))) <> 0 Then
x = x + 1
f.EntireRow.Copy shW.Cells(x, "A")
f.Interior.Color = vbRed
dup = True
End If
For n = 1 To cols
Intersect(f.EntireRow, shT.Range(col(n))).Value = shF.Range(aryA(n - 1)).Value
Next
Else
nfd = nfd & vbLf & shF.Range("A1").Value
End If
shF.Parent.Close False
fName = Dir()
Loop
Application.ScreenUpdating = True
If nfd <> "" Then MsgBox "以下のidがマスターにありませんでした" & vbLf & Mid(nfd, 2)
If dup Then MsgBox "すでにデータ入力済みの行がありました。色を付けてあります"
End Sub
以上、よろしくお願いいたします。
（aaaccc） 2017/04/13(木) 10:32
訂正をお願いした３か所は、レイアウト規定でセットしている情報があるにもかかわらず、 元々固定で処理していたコードを直すのを忘れていた場所で、↑のコードを見る限り、正しく訂正いただいていると思います。
レイアウトとしては タイトル行が７行目、データが８行目から ということのようですから、 こちらで、レイアウトをそのようにし、シート名をマスターに変更したものに対して、 ↑のコードをそのまま実行しましたが、すでに値がある行に対しては 赤く塗られ、Sheet2 にも書きこまれ メッセージもでていますが？
（β） 2017/04/13(木) 13:59
お世話になります。
ご返信ありがとうございます。
もう一度コピペし、試したところ、うまくいきました。
お手数をお掛けし、申し訳ございませんでした。
あと、これは質問なのですが、
現在はセルに入力された共通の値を参照し、転記していますが、
セルの値ではなく、エクセルファイルのファイル名で判別することは可能なのでしょうか？
可能であるならばファイル名とマスターの値が完全一致ではない場合などでも可能なのでしょうか？
たとえば、完全一致ではないが、ファイル名を転記先セルを含んでいる場合（ファイル名が1234（最新）で転記先idセルが1234などの場合など）。
これに関しましては、コードを書いていいただく必要はありませんので、もしお知りであれば、可能かどうかご回答お願いします。
以上、よろしくお願いします。
（aaaccc） 2017/04/13(木) 15:35
評価ブックが 1234.xlsx で ID列が 1234hogehoge なら簡単ですが、その逆ですか。
可能かどうかといわれれば可能です。
評価ブックごとに、従業員一覧のＩＤ欄のＩＤを上から１つずつ、ブック名と Like 比較をすれば 部分一致の行が取得できます。
ただレスポンス的に、ちょっと工夫したくなりますね。
おおよそ、従業員一覧のＩＤ数って、どれぐらいでしょうか？
（β） 2017/04/13(木) 16:26
お世話になります。
ご返信ありがとうございます。
シートの転記とブックからの転記でやりたいことは可能なので、今後何があるかわからないので一応可能かどうか聞いてみたという感じでございます。
今までのよりは難しい感じですよね？
ID数は5000件程度ですね。
以上、よろしくいお願いいたします。
（aaaccc） 2017/04/13(木) 16:41
このトピも書き込みが増えて、スクロールも大変になってきました。
[[20170404151036]] 『複数ファイルからの一括転記 』（aaaccc）
こんなように、本トピのリンクを貼った新しいトピを立ち上げていただけませんか。 今後は、」そちらで継続したいと思います。
ところで、IDですけど、桁数等が統一されているということはないですか。 また、評価ブックの名前ですけど 必ずIDから始まっているというルールはないでしょうか。
たとえば ID は A123456 のような７桁。ブック名は A123456(最新).xlsx とか A123456_新年度.xlsx とか。
そういったルールがあれば、現在の Test の
Set f = idR.Find(What:=shF.Range("A1").Value, LookAt:=xlWhole, LookIn:=xlValues)
これを
Set f = idR.Find(What:=Left(fName,7), LookAt:=xlWhole, LookIn:=xlValues)
に変えるだけでいいのですけど。
（β） 2017/04/14(金) 00:53
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.