[[20170825101801]]　『複数ファイルから値を取得し、転記』（aaaccc）　ページの最後に飛ぶ

『複数ファイルから値を取得し、転記』（aaaccc）

皆さま

お世話になります。
現在、同じ様式の複数のブックから転記先ファイル(以後マスター）に転記するというコードを改良したいのですが、大きく２つの問題があります。

 １．検索キーについて
現在は、マスターの４列目と転記元ファイルのL39（どのファイルも固定）に共通の値があり、それを参照し転記しております。
しかし、４列目は重複したデータがあるのでその問題をクリアしたいという状況です。（ちなみに一意の値の列を新しく作るのは無理という条件です）。
なので以下のように変更したいと考えております。
まず、Ａ列を参照し、重複していないファイルの値を転記→転記されなかったものでＤ列を参照し転記→Ａ、Ｄで転記されなかったデータでＰ列を参照し転記
フィルターによりこれで重複はないと確認しました（今後新たに追加された場合もＰ列の処理まですれば重複はないです）

 ２．マスター転記列について
現在はマスタの見出しが７行目であり、aryT =で指定した名前を探し、その列に転記するという処理です。
しかし、マスターには重複する列名が多数存在しており、このままではうまく処理ができません。
 ２つめ以降の同じ名前の列命を(2)と変更するなど、列名を変更するというのは無理という条件です。

マスターはマスターというシート、転記元ファイルはすべてシート１のみします。
いろいろ不自由な条件ですがご協力ください。

Sub ほかブックからの転記()
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

 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

＜使用 Excel：Excel2013、使用 OS：Windows7 ＞

元は、βさんに作ってもらったコードなのですね。[[20170404151036]]
出典元を明らかにしないと、それは貴方が自力で書いたものと思われて、これだけのコードを書ける人が、なんで他人を頼るのだろう？、となります。

そして昨日、知恵袋で誰かに直してもらおうとして質問し、回答が付かないから消したようですね。同じように思われたのでしょう。
更には、最初に質問したのが余所であり、出典元も書かなかった事から、ここは使い捨てられたのだ、と感じたので、私は手を出しません。 βさんならお優しいので直してくれるかもですが、最近見かけないので、アテにせず、ご自身で頑張って直すのが良いと思いますよ。
（???） 2017/08/25(金) 11:26

コメント返信：

[ 一覧(最新更新順) ]

[[20170825101801]] 『複数ファイルから値を取得し、転記』（aaaccc） ページの最後に飛ぶ

[[20170825101801]]　『複数ファイルから値を取得し、転記』（aaaccc）　ページの最後に飛ぶ