[[20171018152425]]　『他ファイルからのデータ取り込みについて』（uuuu）　ページの最後に飛ぶ

『他ファイルからのデータ取り込みについて』（uuuu）

お世話になります。uuuuと申します。
現在、同じパスにある複数の転記元エクセルファイルより値を取得し、マスターファイルに値を転記するというマクロを作成しております。
マスターファイルは、７行目に各列名が記入されており、それ以降に各種データが入力されております（4500行）。列に関してはA列にid列が入力されており、FH列まで列があります。
　
　このマクロで改良したい点があるのですが、なかなかうまくかず、ご協力していただけると幸いです（このマクロは以前にここの方に手伝ってもらい作りました）。
マクロは具体的には、マスターファイルのA列にあるID列と転記元エクセルファイルのL39セル（idが入力されている）を参照し、等しいidがある場合、そのid列の行に各値を転記するというものです。

改良したい点を以下に記します。

 マスターのA列のIDは重複しております（これは事情により直せないとお考えください）。現在、重複するidがマスターにある場合、若い行の重複id行に各値が転記されてしまいます。それ以降の重複値がある行は転記されません。
　マスターに重複値がある場合、転記処理をせずにそれらの行を検出し、シート２に移したいのです。例えば10行目A列に100というid、2000行目に100というidがある場合、シート２に1～7行目（列名やその他情報）と10行目、20行目をコピーしたいのです。
また、id列に0と空白値があるのですが、それらの場合も同様の処理を行いたいです。

以上、よろしくお願いします。わかりにくい説明で申し訳ございません。

以下にコードを記載します。

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("a", "b", "c", "d", "e", "f", "g")'マスターの転記先列名
aryA = Array("A25", "C15", "C16", "C17", "C18 ", "C19", "C20")'転記セル

tLine = 7 'マスターの列名がある行番号
idCol = 1 'マスターのＩＤ列の列番号

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("L39").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("L39").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 ＞

元のリストにすでにデータが存在するかは、
ワークシート関数のCountifでチェック。
あとはそれの有無で転記先を条件分岐

変数の登場が多すぎて個人的に嫌いなので、
プロシージャは転記を繰り返す部分と、
個々の転記は切り離して考えてみました。

Option Explicit

Sub ほかブックからの転記()

    Dim pName As String
    Dim fName As String
    Dim wbOld As Workbook

    pName = ThisWorkbook.Path & "\"
    fName = Dir(pName & "*.xlsx")

    Do While fName <> ""
        Set wbOld = Workbooks.Open(pName & fName)
        データの転記 wbOld
        wbOld.Close False
        fName = Dir()
    Loop
End Sub

Sub データの転記(ByRef pWb As Worksheet)

    Dim rngList As Range
    Dim rngID As Range
    Dim wsOld As Worksheet

    Set wsOld = pWb.Sheets(1)
    Set rngList = ThisWorkbook.Sheets("取り込みテスト用").UsedRange
    Set rngID = prngList.Range("L39").Value
    If woksheetfunction.CountIf(prngList.Columns(1), rngID.Value) <> 0 Or _
       rngID.Value = Empty Or rngID.Value = 0 Then
        Set rngList = ThisWorkbook.Sheets("Sheet2").UsedRange
    End If

    With rngList
        With .Resize(1).Offset(.Rows.Count)
            .Cells(1).Value = wsOld.Range("A25").Value
            .Cells(1).Value = wsOld.Range("C15").Value
            .Cells(1).Value = wsOld.Range("C16").Value
            .Cells(1).Value = wsOld.Range("C17").Value
            .Cells(1).Value = wsOld.Range("C18").Value
            .Cells(1).Value = wsOld.Range("C19").Value
            .Cells(1).Value = wsOld.Range("C20").Value
        End With
    End With
End Sub

色付けや不正データの数は、
後でSheet2を数えればいいし、
メッセージがどうのよりもシートをアクティブにして、
メッセージは不正データがあったという程度で十分かと思います。

あ、動作確認はしてません。コードを読んで、
流れを確認してください。
（まっつわん） 2017/10/18(水) 17:15

あ、こぴぺしてそのままの部分がありましたね＾＾；
訂正です。

    With rngList
        With .Resize(1).Offset(.Rows.Count)
            .Cells(1).Value = wsOld.Range("A25").Value
            .Cells(2).Value = wsOld.Range("C15").Value
            .Cells(3).Value = wsOld.Range("C16").Value
            .Cells(4).Value = wsOld.Range("C17").Value
            .Cells(5).Value = wsOld.Range("C18").Value
            .Cells(6).Value = wsOld.Range("C19").Value
            .Cells(7).Value = wsOld.Range("C20").Value
        End With
（まっつわん） 2017/10/18(水) 17:18

あぁ。。。も一つ訂正＞＜

＞Sub データの転記(ByRef pWb As Worksheet)
→Sub データの転記(ByRef pWb As WorkBook)

（まっつわん） 2017/10/19(木) 09:04

まっわん様

返信が遅くなり申し訳ございません。
非常にスマートなコードありがとうございます。

実行したところ
「変数が定義されておりません」とメッセージが出て、デバッグでprngListの部分が示されました。
Dim rngList As Range　と書いて頂いたいるのになぜなのでしょうか？（当方vba初心者レベルでずれた質問していたら申し訳ございません）

私も調べつつ、対応できたらまた報告したいと思います。
（uuuu） 2017/10/20(金) 11:38

Option Explicit
Sub ほかブックからの転記()

    Dim pName As String
    Dim fName As String
    Dim wbOld As Workbook
    pName = ThisWorkbook.Path & "\"
    fName = Dir(pName & "*.xlsx")
    Do While fName <> ""
        Set wbOld = Workbooks.Open(pName & fName)
        データの転記 wbOld
        wbOld.Close False
        fName = Dir()
    Loop
End Sub
Sub データの転記(ByRef pWb As Workbook)
    Dim rngList As Range
    Dim rngID As Range
    Dim wsOld As Worksheet
    Set wsOld = pWb.Sheets(1)
    Set rngList = ThisWorkbook.Sheets("取り込みテスト用").UsedRange
    Set rngID = rngList.Range("L39").Value
    If WorksheetFunction.CountIf(rngList.Columns(1), rngID.Value) <> 0 Or _
       rngID.Value = Empty Or rngID.Value = 0 Then
        Set rngList = ThisWorkbook.Sheets("Sheet2").UsedRange
    End If
    With rngList
        With .Resize(1).Offset(.Rows.Count)
            .Cells(1).Value = wsOld.Range("A25").Value
            .Cells(2).Value = wsOld.Range("C15").Value
            .Cells(3).Value = wsOld.Range("C16").Value
            .Cells(4).Value = wsOld.Range("C17").Value
            .Cells(5).Value = wsOld.Range("C18").Value
            .Cells(6).Value = wsOld.Range("C19").Value
            .Cells(7).Value = wsOld.Range("C20").Value
        End With
    End With
End Sub

書いてる途中で、いろいろ書き換えたからですね＾＾；
失礼しました。
他にもバグがあるかも知れません。m(_ _)m
（まっつわん） 2017/10/20(金) 11:59

まっつわん様

迅速なご返信ありがとうございます。
再度試したところ、
「オブジェクトが必用です」と出て、Set rngID = rngList.Range("L39").Valueが示されました。

ご回答いただけると幸いです。
もし私のほうで対応できたらまた報告したいと思います。

（uuuu） 2017/10/20(金) 12:06

Set rngID = rngList.Range("L39").Value →Set rngID = rngList.Range("L39")

無駄なものが付いてますね＾＾；
すみません。

（まっつわん） 2017/10/20(金) 13:06

まっつわん様
マクロは正常に動きました。ありがとうございます。
せっかく書いて頂いて、本当に申し訳ないのですが、
取り込みテスト用シートの該当行に転記し、L39の値が取り込みテスト用シートで重複、0、空白の場合はその行をシート２にまるまる転記するマクロというのは難しいでしょうか？

できれば、
取り込みテスト用シートに一括で転記したいです。

よろしくお願いします。

（uuuu） 2017/10/20(金) 13:37

ちなみに以前は
aryT = Array("a", "b", "c", "d", "e", "f", "g")'マスターの転記先列名
で転記すべき列を判断しておりました。

（uuuu） 2017/10/20(金) 13:39

　＞L39の値が取り込みテスト用シートで重複、0、空白の場合はその行を
　＞シート２にまるまる転記するマクロというのは難しいでしょうか？

その行というのはどの行ですか？

　＞で転記すべき列を判断しておりました。
あぁ、それはループして作業することでコードの行数を減らしてタイピング量を
減らそうという魂胆ですよね？
それで、コードが読みやすければ問題ないですが、
ずらずらと書き並べてもコピペして必要な部分直すだけですので、
あとはどっちが読みやすいかって話しですよね？

で、それがどうしたのかな？？？

（まっつわん） 2017/10/20(金) 14:06

あぁ、わかった

一旦、取り込みテスト用シートにとりあえずコピペして、
さらに、だめなものはシート2に書き出すんですね。

ちょっと今から出かけるのでまた夕方にでも考えます。

（まっつわん） 2017/10/20(金) 14:09

まっつわん様

わたしの説明がわかりにくく申し訳ございません。
その行は
取り込みシートのA列のなかで重複値がある行、A列が0の行、A列が空白の行です。

「一旦、取り込みテスト用シートにとりあえずコピペして、
さらに、だめなものはシート2に書き出すんですね。」
その通りでございます。その際、取り込みシートのA列のなかで重複値がある行、A列が0の行、A列が空白の行の場合は転記元ファイルから転記せず、それらの行をシート２に検出したいという考えです。

イメージとしては
取り込みシート→A列から順に、id、名前、年収、性別
転記元シート→100、加藤、500万、男
　　　　　　　200、佐藤、300万、女
　　　　　　　100、鈴木、400万、万、男

上記の転記元シートが３つあるとして、
idが重複していない佐藤に関しては
取り込みシートのA列が200の行の名前列に佐藤、年収列に300万、性別列に女と転記したいのです。

idが重複している加藤と鈴木に関しては取り込みシートには何もせずに、シート２にそれぞれの行をコピペしたいのです。

前のコードでは取り込みシートのどの列に転記するかについて、
列名（名前、年収、性別）を検索し、該当列に転記するという方法でした。
という報告を一応いたしました（できれば今回もこの方法のままのコードでいきたいです）

以上、よろしくお願いします。

（uuuu） 2017/10/20(金) 16:04

＞idが重複している加藤と鈴木に関しては取り込みシートには何もせずに、
＞シート２にそれぞれの行をコピペしたいのです。
ああ、じゃ、もう一個、作業用のシートを用意して一旦そこに蓄積してから、
どっちのシートに転記するかを決めないと、順次処理するわけにいかないですよね？

＞できれば今回もこの方法のままのコードでいきたいです
半年後、1年後にメンテナンスの必要が出てきたときにどっちが読みやすいかですよね。
まぁ、ちょっと考えてみます。
（僕は普段、10や20のセルの転記なら全部ずらずら書いちゃうので＾＾；）

（まっつわん） 2017/10/20(金) 16:23

まっつわん様

何度もご返信ありがとうございます。
蓄積するとのことですが、このままのシート状態（取り込みテスト用）で転記処理をして、
重複値等の場合はシート２にコピペするというのは可能でしょうか？わがままで申し訳ないです。

転記する行を７行目の名前以外で判別する以外の方法もあるのでしょうか？
列の追加削除が今後あるかもしれないので、この方法が一番かなあと思っておりました。

（uuuu） 2017/10/20(金) 16:37

＞重複値等の場合はシート２にコピペするというのは可能でしょうか？わがままで申し訳ないです。
可能ですが、元にあったデータは重複をゆるすのですよね？
自動でやるので結果さえ合ってれば方法論は問わないはずですが。。。？

＞転記する行を７行目の名前以外で判別する以外の方法もあるのでしょうか？
あると思いますが、シートがどのようになっているか知らないので、
何とも言えません。

＞列の追加削除が今後あるかもしれないので、この方法が一番かなあと思っておりました。
あぁ、どうでしょうね。
ずらずら書いた方がわかりやすいかなとは思いますが、
それぞれ人によって感じ方は違うでしょう。
コメントでどの項目のことかを書けるので

例）

            .Cells(1).Value = wsOld.Range("A25").Value    '氏名
            .Cells(2).Value = wsOld.Range("C15").Value　　'住所
            .Cells(3).Value = wsOld.Range("C16").Value　　'電話

1行の中に値を羅列して行ったら、
何番目がどれか数えないとわかんないですよねー・・・
ま、好き好きでそこは自分でどうにかしてください。

コードは明日以降考えてみますが、自分用に作りかけのメモで貼っておきます。
（どこででも作業出来るようにです）

Option Explicit

Sub 新しいデータの追加()

    Dim sPath As String
    Dim wsOK As Worksheet
    Dim wsNG As Worksheet
    Dim wsWork As Worksheet
    Dim rngOldData As Range

    With ThisWorkbook
        sPath = .Path & "\"
        Set wsWork = .Sheets("作業用")
        Set wsOK = .Sheets("取り込みテスト用")
        Set wsNG = .Sheets("Sheet2")
    End With
    'フォルダー内のエクセルファイルを巡回し必要項目を作業用シートに集積
    Set rngOldData = Get_集積(sPath, wsWork)

    '正規のデータと不正なデータと振り分けて転記
    Set振り分け wsOK, wsNG, rngOldData
End Sub

Private Function Get_集積(ByVal wsPath As String, ByVal wwsWork As Worksheet)

    Dim sFName As String
    Dim wb As Workbook
    Dim rngID As Range
    Dim rngFrom As Range
    Dim rngTo As Range
    Dim c As Range
    Dim i As Long

    sFName = Dir(wsPath & "*.xlsx")
    Do While fName <> ""
        Set wb = Workbooks.Open(wsPath & sFName)
        Set rngFrom = wb.Sheets(1).Range("L39,A25,C15:C20")
        With wwsWork.UsedRange
            Set rngTo = .Resize(1).Offset(.Rows.Count)
        End With
        For Each c In rngFrom.Cells
            i = i + 1
            rngTo(i).Value = c.Value
        Next
    Loop
    Get_集積 = wwsWork.UsedRange.Value
End Function

Private Sub Set_振り分け(ByVal wwsOK As Worksheet, _

                     ByVal wwsNG As Worksheet, _
                     ByVal wrngOldData As Range)

End Sub

（まっつわん） 2017/10/20(金) 17:29

少し自分でも考えてみたいと思います。！
ありがとうございます！
（uuuu） 2017/10/20(金) 17:49

っと、本業が忙しくなってしまって書き込みが遅くなりました。

大枠だけもう一度見直しました。

作業の流れはあってますでしょうか？

流れがあっていれば、詳細部分についてそれぞれ煮詰めます。

Sub メイン()

    Dim sFolderPath As String   '検索するフォルダーのパス
    Dim sFileName As String     '検索されたファイル名
    Dim vntData As Variant      'ブックから取り出したデータ
    Dim flg As Boolean          'データのチェック結果

    sFolderPath = ThisWorkbook.Path & "\"
    'ファイルの検索
    sFileName = Dir(sFolderPath & "*.xlsx")
    Do While Len(sFileName) > 0
        'フルパスを指定してデータを取り出す
        vntData = Get_Data(sFolderPath & sFileName)
        '正規のデータかチェックする
        flg = Chk_Data(vntData)
        '転記（フラグで転記先分別)
        Set_Record vntData, flg
        '次を検索
        fName = Dir()
    Loop
End Sub
（まっつわん） 2017/10/23(月) 11:39

Get_Dataの自作関数部分だけ作りました。
今日は忙しいのであとは明日以降で。。。m(_ _)m

'*******************************************************************************
' 「Get_Data」　シート上に点在するデータ一次配列で返す自作関数
'*******************************************************************************
'*【戻値】：点在するデータを1次配列で返す（Variant型）
'*【引数】：ブックのフルパス（String型）
'*【注意】：※フルパスを指定しブックを開き1番目のシートに
'*　　　　　　対して処理を行う
'* ※要素数が変更になる場合はコードを改変すること
'*******************************************************************************
Private Function Get_Data(ByVal sFullPath As String)

    Dim wb As Workbook
    Dim v(1 To 5) As Variant

    On Error Resume Next
    Set wb = Workbooks.Open(sFullPath)
    On Error GoTo 0

    If wb Is Nothing Then Exit Sub
    With wb.Sheets(1)
        v(1) = .Range("L39").Value  'ID
        v(2) = .Range("A25").Value  '氏名
        v(3) = .Range("C15").Value  '住所
        v(4) = .Range("C16").Value  '電話番号
        v(5) = .Range("C20").Value  'その他
    End With

    wb.Close False
    Set wb = Nothing

    Get_Data = v
End Function
'***********************************************************************************
（まっつわん） 2017/10/23(月) 17:13

残りの部分も書いてみました。

'*******************************************************************************
' 「Chk_Data」　データ内のIDの重複及び欠落をチェック
'*******************************************************************************
'*【戻値】：OK or NG をブール型で返す（Boolean型）
'*【引数】：一次配列のデータ（Variant型）
'*【注意】：※渡された一次配列の1つ目のデータについて
'*　　　　　　指定のシート上のデータとチェックする
'*******************************************************************************
Private Function Chk_Data(ByVal v As Variant) As Boolean

    Dim rngTalble As Range
    Dim m As Long

    If v(1) = Empty Then GoTo WayOut
    If v(1) = 0 Then GoTo WayOut

    Set rngTalble = ThisWorkbook.Sheets("取り込みテスト用").UsedRange
    On Error GoTo WayOut
    m = WorksheetFunction.Match(v(1), rngTalble.Columns(1), 0)
    chk = cbln(m)
    Exit Function

WayOut:
End Function
'*******************************************************************************

'*******************************************************************************
' 「Set_Record」　フラグにより条件分岐して転記する
'*******************************************************************************
'*【戻値】：なし
'*【第一引数】：一次配列のシートに書き込むデータ
'*【第二引数】：転記先のフラグ
'*【注意】：※転記先をフラグにより分ける
'*******************************************************************************
Private Sub Set_Record(ByVal v As Variant, ByVal flg As Boolean)

    Dim rngTargetRow As Range

    With ThisWorkbook
        If flg Then
            Set rngTargetRow = .Sheets("取り込みテスト用").UsedRange
        Else
            Set rngTargetRow = .Sheets("Sheet2").UsedRange
        End If
    End With
    With rngTargetRow
        Set rngTargetRow = .Rows(.Count + 1)
    End With

    rngTargetRow.Value = v
End Sub

慣れないと、プロシージャ分けたことが、読みにくく感じるかも知れませんが、
作業毎に分けて考えると改変が楽になるかと思います。

※相変わらず動作確認はこちらではしてません。
一つのやり方として参考までに、こういうやり方で開発していくといいかなと思いました。
（まっつわん） 2017/10/24(火) 09:26

Chk_Data
のロジックが間違ってましたね。修正

Private Function Chk_Data(ByVal v As Variant) As Boolean

    Dim rngTalble As Range
    Dim vID As Variant

    vID = v(1)
    Set rngTalble = ThisWorkbook.Sheets("取り込みテスト用").UsedRange.Columns(1)
    If vID = Empty Then Exit Function
    If vID = 0 Then Exit Function
    If WorksheetFunction.CountIf(rngTalble, vID) > 0 Then Exit Sub
    Chk_Data = True
End Function

プロシージャを分けるということは、こうやって部品だけの交換が容易になるということです。
（まっつわん） 2017/10/25(水) 08:27

コメント返信：

[ 一覧(最新更新順) ]

[[20171018152425]] 『他ファイルからのデータ取り込みについて』（uuuu） ページの最後に飛ぶ

[[20171018152425]]　『他ファイルからのデータ取り込みについて』（uuuu）　ページの最後に飛ぶ