[[20170404151036]] 『複数ファイルからの一括転記 』(aaaccc) >>BOT

[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]

 

『複数ファイルからの一括転記 』(aaaccc)

いつも参考にしております。
表題の件なのですが、vbaを活用し、複数(数百)のブックの値を一つのブックに転記したいです。
たとえば、各社員の評価ファイルの評価値を従業員名簿の各社員に対応するセルに一括転記したいです。

 具体的には、 
・従業員名簿のa列には固有ID列があり、各社員の評価ファイルのA1にも同様の固有IDが入力されています。 
(この固有IDを使って、転記する行を参照したいです)
・各社員の評価ファイルは数百ファイルあるとし、転記したい評価値セルはC4、D4、(全ファイル固定)とします。 
・転記先は従業員名簿のC、D列の各社員に該当するセルにしたいです。 
・従業員名簿ファイルと各社員の評価ファイルは同じフォルダに格納しております。 

あくまで、エクセル関数ではなくvbaで実行したいと考えております。

ファイルイメージは以下のようになります。

<従業員名簿>  (転記前)
A   B  C  D
1  加藤
2  鈴木
3  佐藤

<加藤の評価ファイル> 

A1に1、C4にB、D4にCが入力済み

<従業員名簿>  (3名のファイル転記後)
A  B C  D
1  加藤  B  C
2  鈴木  A  A
3  佐藤  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


 コードの説明ですが、1行1行、すべて解説しても、かえって煩雑かもしれません。
 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


βさま
続けてもうしわけございません。
上書き対象データ(シート2)を確認したところ、
複数回同じ行が抽出されております。
たとえば、1, 加藤, A, C という行が複数行抽出されております。

なぜでしょうか?
(aaaccc) 2017/04/06(木) 13:42


 コード説明は後に回して質問の件。

 そちらの各ブックのデータが見えないのでなんともいえないのですが、コードでは上書き前の従業員一覧の
 内容と各ブックの内容を比較しています。

 ですから 1 加藤(コードでチェックしているのは 1 だけですが)に値がすでに入っていた。
 それに対して各ブックの複数のブックに 1 加藤 があった場合は、複数行SHeet2に書きこまれます。

 こういった場合も、あくまで 1行だけ(最初にあらわれた 1 加藤 の分だけ)Sheet2に記載するということは
 もちろんできますが。

( β) 2017/04/06(木) 15:40


βさま

お世話になります。
なるほど、そういうことでしたか。
どれくらいのファイルで一括に行えるかテストしたため、A1に1が入力されたファイルを多数配置しておりました。
それならば、β様が記述された処理のほうが好ましいですね。

ありがとうございます。
(aaaccc) 2017/04/06(木) 15:47


 コード説明です。

 ●    Set nfd = CreateObject("System.Collections.ArrayList")

  VBAコードは基本的には、VBAが提供してくれる標準機能を組み合わせて組み立てます。
  ただ、ケースによっては、VBA以外のプログラムを利用したい場合もでてきます。

  ・そのプログラムを使わないと実現できない。
  ・そのプログラムを使うほうが、よりコード記述がシンプルになる。
  ・そのプログラムを使うほうが、処理効率が格段にアップする。

  こういったケース。たとえば、よく使われるユーザーフォームもVBAの持ちものではなく
  別プログラムです。

  で、この別プログラムを呼びだして利用可能にする方法はいくつかあるんですが、最もシンプルなのは

  CreateObject("そのプログラムに割り当てられたプログラムID文字列") 

  こうして、そのプログラム(オブジェクト)を取得します。

  ここでは ArrayList と呼ばれるプログラム(後述)を呼び出しています。

 ● ArrayList

  ArrayList は、きわめてシンプルな構造の、データを複数格納しておける『容器』と
  そこへの格納、取り出しといった機能を提供してくれるプログラムです。
  今回は使っていませんが、格納されたデータを昇順に並び替えたり、さらに降順に並び替えることも可能です。

  似たようなプログラムで、キーとデータをペアで格納しておくことができる Dictinary や SortedList といったものもあります。

 ●v = .Columns(3).Resize(, 2).Value(リサイズのほうはなぜカンマがあるのでしょうか?) 

  Resize は 元のセル領域.Resize(行数の変更数,列数の変更数) と書きます。
  元のサイズと同じでいい場合は省略可能です。

  従って Resize(, 2) は 行数としては、元の領域と同じ、列数は 2列に変更 という意味です。
  ちなみに、ここで、元の領域は .Columns(3) つまり、A1 から始まる連続したデータ領域全体の3列目。
  つまり、C1:C● になっていますので、Resize結果は C1:D● になります。

 ●ループ処理

  ここで使っているループ処理は、フォルダからファイル名を抽出する DIR関数によるループ処理の定番コードです。
  DIR関数に対して フォルダパスを含むファイルフルパス(ワイルドカード指定可能)を与えると、該当のファイル名を
  返してくれます。

  fName = Dir(fpath & "*.xlsx")

  最初に与えているのはフォルダ文字列と *.xlsx。 * がワイルドカードで、フォルダ内の xlsx ブックを抽出という意味です。

  Do While fName <> ""

  DIR関数の結果が空白になれば、もうファイルはない ということになり、繰り返し処理を終了します。
  ここでは 空白ではなかったら、つまり ファイルが存在すれば という判定をしています。
  で、ファイルがあった場合、 Fname にブック名が入っていますので、それにフォルダパスを加えて ブックを開き
  必要な処理を行い、ブックを閉じます。

  で、引き続き fName = Dir() 。 2回目以降の 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、D4の値を従業員名簿のC、D列の対応するセルに入力しています。
今後この例で言う従業員名簿は列が追加削除される可能性があります(行はもちろん追加削除します)。
そこで問題になりそうなのが、たとえば従業員名簿のB列(名前列)の次に年収列を新たに追加するとしたら、年収列に評価値が転記されてしまいますよね?
こういった列の追加削除に柔軟に対応(できれば、ユーザーが何もせずとも列の追加削除に対応)することは可能なのでしょうか?
評価ファイルはおそらく今後も変更はないと思います。

追加の質問になり申し訳ないですが、よろしくお願いいたします。

(aaaccc) 2017/04/10(月) 11:14


 列関連のレイアウトが変更されても 評価ファイルの所定のセルの値を、変更後の列の位置に正しく反映するためには
 方法は 2つしかないです。

 1.変更された列にあわせて、コードを変更する。
 2.現在は、1行目からデータになっているようですが、通常は、1行目にはタイトル行を設けるのが
   エクセルによるデータ管理の鉄則です。
    で、たとえば、現在の C列 のタイトルとして "評価1" 、D列のタイトルとして "評価2" といったものをセットしておく。
   そうしておけば、列が挿入されたり、あるいはまた削除されたりして、列の位置が変更になっても、マクロ内で
   1行目の "評価1" や "評価2" といった文字列を Findメソッドなり MATCH関数なりで検索し、ヒットした列が
   それぞれの値を転記すべき列だと、そう判定することができますので。

(β) 2017/04/10(月) 11:30


βさま

さっそくのご返信ありがとございます。
2の方法に関してなのですが、
実際のデータでは1行目はタイトルとして管理しております。
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


 該当の列がどこにあろうと、2列だけを相手にするということであれば、★★のところを 実際のタイトル文字列にするだけでOKです。

 そのほかは一切変更不要です。

( β) 2017/04/10(月) 17:04


βさま

ご返信ありがとうございます。
では、3箇所を転記する場合は
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〜7は別のデータで関係ないデータや空白セル)で共通id列が4列目、転記先列は評価1が166列目、評価2が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


 2列限定、かつ連続した2列 というものを相手にするバージョンですね。

 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


βさま

お世話になります。
さっそくのご返信ありがとうございます。

2列限定、かつ連続した2列
ではなくたとえば3列(もしくはそれ以上)で連続していない(たとえば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                                   '従業員一覧のID列の列番号
    '================================================================================================

    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   '処理前にID列の背景色を取り除く
        Set idR = .Cells                'ID領域
    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 を追加したところうまくいきました。
あと、重複があった場合、上書きシートに上書き前のデータをコピペすると思うのですが、
その際8行目(列名)も一緒に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のシートの1行目に 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                                 '転記すべき領域の行数

 この2つを消しておいてください。

(β) 2017/04/12(水) 15:47


βさま

お世話になります。
うまくいきました。

シート間の転記についてなのですが、
何件か前のレスポンスで。
「同じブック内でシート名がsheet3のシートからa1(id)を参照し、"C4", "D4", "E4を転記する場合は、」
といってたのですが、勘違いしておりまして、
sheet3の転記したい列は決まっているのですが、行番号が4固定ではなく何行目か決まっておりません。
下記で、sheet3からC,D列をsheet1に転記のイメージを書きます。

<従業員名簿>  (転記前)
sheet1
A   B  C  D
1  加藤

 2  鈴木 
 3  佐藤 
sheet3
A        B       C      D 
3       佐藤     A    C
1       加藤    E    E
2       鈴木    B    B

<従業員名簿>  (転記後)
sheet1
A   B     C   D

 1  加藤   E     E
 2  鈴木    B    B
 3  佐藤     A    C

みたいな感じです。
sheet1と3で共通のidはあるのですが、順番は同じとは限らないという条件です。
この場合もマクロによる転記は可能なのでしょうか?

よろしくいお願いします。
(aaaccc) 2017/04/12(水) 16:45


 はい、可能ですよ。

 確認します。
 今までは 別フォルダの評価ブックのシートから、従業員名簿に転記していたわけですけど
 今回は "Sheet3" の、これも一覧になっている、そのリストから ID なのか 名前なのかわかりませんけど
 それがマッチする行に転記したいということですね。

 後出しで、コードを再作成するのはつかれるので、以下の点、明確にしてください。

 1.Sheet1 と Sheet3 のレイアウトは、全く同じですか? タイトル行の位置とか、セットすべき項目(列)の位置とか。
 2.あるいは、それぞれ、タイトル行の行番号も異なる、ID(名前?)列の列も異なる、転記したい評価項目の列も異なる?

 いずれでもできますが、明確にしてくださいね。

 ●ただし、2.だと、それなりにコードは複雑になります。

 ★現在のバージョンがすでに、従業員一覧の順番は、必ずしも フォルダ内のブックの順番ではないですよね。
  各評価ブックのIDを 従業員一覧の ID列で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


 明日は、終日時間が取れないかもしれませんので見切り発車。

 最初のほうのレイアウト規定部分、少し設定内容を変えました。
 実際のものに変えてください。

 従業員一覧シート、転記元シート、それぞれ 対象の列や タイトル行の行番号は 同じでなくてもOK。
 ただし、対象列の項目名は同じというしばりです。

 Sheet3 から転記しようとして SHeet1 になかったものには SHeet3 側のIDセルに色塗り を追加してあります。
 後は、今までのものと同じ仕様です。

 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                                      '従業員一覧のID列の列番号
    idColF = 2                                      '転記元シートのID列の列番号
    '================================================================================================

    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     '処理対象列数
    '従業員一覧 ID領域
    Set idRT = Range(shT.Cells(tLineT + 1, idColT), shT.Columns(idColT).Find(What:="*", LookAt:=xlWhole, LookIn:=xlValues, SearchDirection:=xlPrevious))
    '転記元 ID領域
    Set idRF = Range(shF.Cells(tLineF + 1, idColF), shF.Columns(idColF).Find(What:="*", LookAt:=xlWhole, LookIn:=xlValues, SearchDirection:=xlPrevious))

    idRT.Interior.ColorIndex = xlNone   '処理前に従業員一覧ID列の背景色を取り除く
    idRF.Interior.ColorIndex = xlNone   '処理前に転記元シートID列の背景色を取り除く

    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にコピペし、メッセージボックスを出すという処理が行われなくなりました
(シート2の1行目に列名はコピーされるのですが、重複データはコピーされないという状況です。
自分で修正できたら、報告したいと思います。
お忙しいと思いますが、時間があるときにでもよろしくお願いします。

以下が現在のコードです。(シート名とメッセージボックスの文言を変えております)

  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                                   '従業員一覧のID列の列番号
    '================================================================================================

    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   '処理前にID列の背景色を取り除く
        Set idR = .Cells                'ID領域
    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


 訂正をお願いした3か所は、レイアウト規定でセットしている情報があるにもかかわらず、
 元々固定で処理していたコードを直すのを忘れていた場所で、↑のコードを見る限り、正しく訂正いただいていると思います。

 レイアウトとしては タイトル行が7行目、データが8行目から ということのようですから、
 こちらで、レイアウトをそのようにし、シート名をマスターに変更したものに対して、
 ↑のコードをそのまま実行しましたが、すでに値がある行に対しては 赤く塗られ、Sheet2 にも書きこまれ
 メッセージもでていますが?

(β) 2017/04/13(木) 13:59


βさま

お世話になります。
ご返信ありがとうございます。
もう一度コピペし、試したところ、うまくいきました。
お手数をお掛けし、申し訳ございませんでした。

あと、これは質問なのですが、
現在はセルに入力された共通の値を参照し、転記していますが、
セルの値ではなく、エクセルファイルのファイル名で判別することは可能なのでしょうか?
可能であるならばファイル名とマスターの値が完全一致ではない場合などでも可能なのでしょうか?
たとえば、完全一致ではないが、ファイル名を転記先セルを含んでいる場合(ファイル名が1234(最新)で転記先idセルが1234などの場合など)。

これに関しましては、コードを書いていいただく必要はありませんので、もしお知りであれば、可能かどうかご回答お願いします。

以上、よろしくお願いします。
(aaaccc) 2017/04/13(木) 15:35


 評価ブックが 1234.xlsx で ID列が 1234hogehoge なら簡単ですが、その逆ですか。

 可能かどうかといわれれば可能です。

 評価ブックごとに、従業員一覧のID欄のIDを上から1つずつ、ブック名と Like 比較をすれば
 部分一致の行が取得できます。

 ただレスポンス的に、ちょっと工夫したくなりますね。

 おおよそ、従業員一覧のID数って、どれぐらいでしょうか?

(β) 2017/04/13(木) 16:26


βさま

お世話になります。
ご返信ありがとうございます。
シートの転記とブックからの転記でやりたいことは可能なので、今後何があるかわからないので一応可能かどうか聞いてみたという感じでございます。
今までのよりは難しい感じですよね?

ID数は5000件程度ですね。

以上、よろしくいお願いいたします。
(aaaccc) 2017/04/13(木) 16:41


 このトピも書き込みが増えて、スクロールも大変になってきました。

[[20170404151036]] 『複数ファイルからの一括転記 』(aaaccc)

 こんなように、本トピのリンクを貼った新しいトピを立ち上げていただけませんか。
 今後は、」そちらで継続したいと思います。

 ところで、IDですけど、桁数等が統一されているということはないですか。
 また、評価ブックの名前ですけど 必ずIDから始まっているというルールはないでしょうか。

 たとえば ID は A123456 のような7桁。ブック名は 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.