[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『データの一括転記について』（ACA）
Excelの学校の皆様
お世話になります。
ACAと申します。当方、VBA初心者レベルでご迷惑をお掛けするかもしれませんが、ご協力よろしくお願いいたします。
以前、ここの方に協力してマクロを作成していただいたのですが、少し改良、修正をしたいと考えております。
現在、同じパスにある複数の転記元ファイルからデータ統合用転記先ファイル（以降、マスター）にデータを一括で転記しております。
具体的にはマスターのA列にIDコードがあり、転記元ファイルのL39セル（id入力列）を参照し、マスターに入力する行を判断して、転記おります。実際のデータは9行目から始まっております。
また、マスターのA列で0、空白、重複値の行を重複データ一覧シートに抽出しております。
改良点を以下に記載します。
?@L39セルに0、空白、マスターA列重複値が入力された場合の処理
現在：インデックスが有効にないと表示されてしまう。
改良後：転記元ファイルのL39セルに0、空白、マスターA列に重複している値が入力された場合、処理をしない。
「重複IDがあります」のメッセージボックスを｛ファイルを取り込みました」のメッセージボックスの前に表示させる。
?A取り込みデータ一覧シートの作成
マスターに取り込んだデータの一覧表を新規シートに作成する（毎回上書き）。
そのシートにマスターの1～8行目をコピーし、9行目以降に取り込んだデータ（行を丸ごと）をリスト化したいです。
?Bフィルターをかけたままマクロを実行
現在のコードをフィルターで絞り込んだ状態で実行すると、エラーが出てしまうので、フィルターを解除している（With shT
If .FilterMode Then .ShowAllData End With）
改良後は、マクロ実行前と同じフィルターをかけた状態でマクロを終了したいです。
以上、よろしくお願いいたします。
以下にコードを貼り付けます。
Dim aryT As Variant, aryA As Variant, colAdr()
Dim n As Long, mx As Long, cnt As Long Dim shT As Worksheet, shF As Worksheet, shW As Worksheet Dim idR As Range, f As Range Dim fpath As String, fName As String, nfd As String Dim dup As Boolean, flg As Boolean
Application.ScreenUpdating = False
'マスターの転記先列名 aryT = Array(136, 137, 138, 139, 140, 141, 142, 143)
'転記セル
aryA = Array("G12", "A25", "C15", "C16", "C17", "C18 ", "C19", "C20")
'★マスターシート
Set shT = ThisWorkbook.Sheets("マスター")
'★重複データリスティングシート
Set shW = ThisWorkbook.Sheets("重複データ一覧")
With shT
If .FilterMode Then .ShowAllData
End With
shW.Cells.ClearContents
' shT.Rows(tLine - 4 & ":" & tLine).Copy shW.Range("A2")
shT.Rows("1:8").Copy shW.Range("A1")
mx = shT.Cells(shT.Rows.Count, idCol).End(xlUp).Row
'マスターのＩＤ範囲を設定 Set idR = shT.Range(shT.Cells(tLine + 2, idCol), shT.Cells(mx, idCol))
'マスターでＩＤが重複している行などを重複データ一覧へ転記 mx = 9 For Each f In idR cnt = WorksheetFunction.CountIf(idR, f.Value) If cnt > 1 Or f.Value = 0 Or f.Value = "" Then f.EntireRow.Copy Destination:=shW.Rows(mx) mx = mx + 1 dup = True End If Next f 'ファイルを検索して処理 fpath = ThisWorkbook.Path & "\" fName = Dir(fpath & "*.xlsx") Do While fName <> ""
Set shF = Workbooks.Open(fpath & fName).Sheets(1)
cnt = WorksheetFunction.CountIf(idR, shF.Range("L39").Value)
flg = False
If cnt = 1 Then
If shF.Range("L39").Value <> 0 And shF.Range("L39").Value <> "" Then
Set f = idR.Find(What:=shF.Range("L39").Value, LookAt:=xlWhole, LookIn:=xlValues)
If Not f Is Nothing Then
For n = LBound(aryA) To UBound(aryA)
shT.Cells(f.Row, aryT(n)).Value = shF.Range(aryA(n)).Value
Next n
flg = True
End If
End If
End If
If Not flg Then
mx = shW.Cells(shW.Rows.Count, idCol).End(xlUp).Row + 1
shW.Cells(mx, idCol).Value = fName & " : " & shF.Range("L39").Value
For n = LBound(aryA) To UBound(aryA)
shW.Cells(mx, colAdr(n)).Value = shF.Range(aryA(n)).Value
Next n
nfd = nfd & vbCrLf & fName & " : " & shF.Range("L39").Value
End If
shF.Parent.Close False fName = Dir()
Loop
MsgBox "ファイルを取り込みました。"
End Sub
＜ 使用 Excel：Excel2010、使用 OS：Windows7 ＞
『データの一括転記について』（ACA）
Excelの学校の皆様
お世話になります。
ACAと申します。当方、VBA初心者レベルでご迷惑をお掛けするかもしれませんが、ご協力よろしくお願いいたします。
以前、ここの方に協力してマクロを作成していただいたのですが、少し改良、修正をしたいと考えております。 現在、同じパスにある複数の転記元ファイルからデータ統合用転記先ファイル（以降、マスター）にデータを一括で転記しております。 具体的にはマスターのA列にIDコードがあり、転記元ファイルのL39セル（id入力列）を参照し、マスターに入力する行を判断して、転記おります。実際のデータは9行目から始まっております。 また、マスターのA列で0、空白、重複値の行を重複データ一覧シートに抽出しております。
改良点を以下に記載します。
1.L39セルに0、空白、マスターA列重複値が入力された場合の処理
現在：インデックスが有効にないと表示されてしまう。 改良後：転記元ファイルのL39セルに0、空白、マスターA列に重複している値が入力された場合、処理をしない。 「重複IDがあります」のメッセージボックスを｛ファイルを取り込みました」のメッセージボックスの前に表示させる。
2.取り込みデータ一覧シートの作成
マスターに取り込んだデータの一覧表を新規シートに作成する（毎回上書き）。
そのシートにマスターの1～8行目をコピーし、9行目以降に取り込んだデータ（行を丸ごと）をリスト化したいです。
3.フィルターをかけたままマクロを実行
現在のコードをフィルターで絞り込んだ状態で実行すると、エラーが出てしまうので、フィルターを解除している（With shT If .FilterMode Then .ShowAllData End With） 改良後は、マクロ実行前と同じフィルターをかけた状態でマクロを終了したいです。
以上、よろしくお願いいたします。
以下にコードを貼り付けます。
Sub データ取り込み()
Const idCol As Long = 1 'マスターのＩＤ列の列番号
Const tLine As Long = 7 'マスターの列名がある行番号
Dim aryT As Variant, aryA As Variant, colAdr()
Dim n As Long, mx As Long, cnt As Long Dim shT As Worksheet, shF As Worksheet, shW As Worksheet Dim idR As Range, f As Range Dim fpath As String, fName As String, nfd As String Dim dup As Boolean, flg As Boolean
Application.ScreenUpdating = False
'マスターの転記先列名 aryT = Array(136, 137, 138, 139, 140, 141, 142, 143)
'転記セル
aryA = Array("G12", "A25", "C15", "C16", "C17", "C18 ", "C19", "C20")
'★マスターシート
Set shT = ThisWorkbook.Sheets("マスター")
'★重複データリスティングシート
Set shW = ThisWorkbook.Sheets("重複データ一覧")
With shT
If .FilterMode Then .ShowAllData
End With
shW.Cells.ClearContents
' shT.Rows(tLine - 4 & ":" & tLine).Copy shW.Range("A2")
shT.Rows("1:8").Copy shW.Range("A1")
mx = shT.Cells(shT.Rows.Count, idCol).End(xlUp).Row
'マスターのＩＤ範囲を設定 Set idR = shT.Range(shT.Cells(tLine + 2, idCol), shT.Cells(mx, idCol))
'マスターでＩＤが重複している行などを重複データ一覧へ転記 mx = 9 For Each f In idR cnt = WorksheetFunction.CountIf(idR, f.Value) If cnt > 1 Or f.Value = 0 Or f.Value = "" Then f.EntireRow.Copy Destination:=shW.Rows(mx) mx = mx + 1 dup = True End If Next f 'ファイルを検索して処理 fpath = ThisWorkbook.Path & "\" fName = Dir(fpath & "*.xlsx") Do While fName <> ""
Set shF = Workbooks.Open(fpath & fName).Sheets(1)
cnt = WorksheetFunction.CountIf(idR, shF.Range("L39").Value)
flg = False
If cnt = 1 Then
If shF.Range("L39").Value <> 0 And shF.Range("L39").Value <> "" Then
Set f = idR.Find(What:=shF.Range("L39").Value, LookAt:=xlWhole, LookIn:=xlValues)
If Not f Is Nothing Then
For n = LBound(aryA) To UBound(aryA)
shT.Cells(f.Row, aryT(n)).Value = shF.Range(aryA(n)).Value
Next n
flg = True
End If
End If
End If
If Not flg Then
mx = shW.Cells(shW.Rows.Count, idCol).End(xlUp).Row + 1
shW.Cells(mx, idCol).Value = fName & " : " & shF.Range("L39").Value
For n = LBound(aryA) To UBound(aryA)
shW.Cells(mx, colAdr(n)).Value = shF.Range(aryA(n)).Value
Next n
nfd = nfd & vbCrLf & fName & " : " & shF.Range("L39").Value
End If
shF.Parent.Close False fName = Dir()
Loop
MsgBox "ファイルを取り込みました。"
End Sub
（ACA） 2017/11/27(月) 17:09
＞1.L39セルに0、空白、マスターA列重複値が入力された場合の処理 ＞ 現在：インデックスが有効にないと表示されてしまう。
どの行でしょうか？
＞改良後：転記元ファイルのL39セルに0、空白、 ＞マスターA列に重複している値が入力された場合、処理をしない。 ＞「重複IDがあります」のメッセージボックスを｛ ＞ファイルを取り込みました」のメッセージボックスの前に表示させる。
if len(nfd)>0 then msgbox "重複IDがあります" & vblf & nfd
＞2.取り込みデータ一覧シートの作成 ＞マスターに取り込んだデータの一覧表を新規シートに作成する（毎回上書き）。 ＞そのシートにマスターの1～8行目をコピーし、 ＞9行目以降に取り込んだデータ（行を丸ごと）をリスト化したいです。
まずは、シートを準備してください。
＞3.フィルターをかけたままマクロを実行
Findによる検索をやめて、application.matchで検索してください。
（マナ） 2017/11/27(月) 22:49
[[20170404151036]] 『複数ファイルからの一括転記 』（aaaccc）
（マナ） 2017/11/27(月) 23:00
んと、マクロを作るのはあなたですよね？
他人のコードを読むのも結構、辛い作業です。（インデントくらいはちゃんとして欲しい）
思い付きを途中から盛り込むのは結構難しいです。
初心者なのだから、何度でも新たに書き直したらいいのでは？
ということで、
まずは前提条件と作業の流れを整理してみて、
それを箇条書きで説明してみるところから始めてみてはいかがでしょうか？
前提条件としては、
1）マクロを置いておくブックにデータを集積する
2）データの集積はIDの有無をチェックし、集積するシートを分ける
3）データは特定のフォルダに複数のエクセルファイルの状態で存在している
こんなとこでしょうか？
作業の流れてとしては
1）OKなデータを集積するシートの定義
2）NGなデータを集積するシートの定義
3）巡回してデータを読むファイルのリストの取得（ファイルのフルパスのリスト）
4）取得したファイルのリストを巡回してデータを取り込む
メインの流れはこんな感じでしょうか？
擬似コードを書くと
sub 纏める()
'準備（前提条件の定義または取得）
set OK ＝ このブックの「OK」というシート
set NG = このブックの「NG」というシート
ファイルのリスト = Get_ファイル一覧（ファイルがあるフォルダのパス）
For Each リストの中の各要素 in ファイルのリスト
Call データの取り込み（リストの中の各要素,OK,NG)
next
end sub
次に3のサブルーチン（＝特定の機能を果たすためのまとまりのある部分。）の流れを細かく考える。
これは今までのサンプルで理解されているのかな？
それを、ファイルのフルパスの一覧を配列で返す自作関数にしてみる
4は4でまた、その作業（≒機能）を実現するよう考えてみる。
以下省略。。。
まぁ、こんな感じで少しずつ機能というか部品いうかそういう小さい単位で考えて、
少しずつ勉強しながらやりたいことを実現できるようになれたらいいですね。
（まっつわん） 2017/11/28(火) 09:24
そして、またしても知恵袋に書いて無視されて（まぁ、回答者からの意見を無視したようだし、そうなるでしょう）、またこっちで他人に作らせようとしてますね？ せっかく良いサンプルをもらったのだから、後は何としてでもご自分で対応しないと駄目ですよ。けっこう高度なコーディングになってしまっているので、余所でこれを見せても、こんなベテランの作ったコードには誰も手を出そうとしない事でしょう。高度な事をしているのに、インデントが消えてしまって読みにくくなり、原作を踏みにじる結果になっているので、尚更です。 段付けは、とても大事なんですよ？
オートフィルタを解除しないと、End(xlUp)による最終行取得がうまくいかない事に気づき、ご自分で解除処理を追加したようなので、多少やる気が見える点に応じて、アドバイスだけ。 元がどういうフィルタだったかを調べて、それを再現する事は、ちょっと面倒です。なのでこのアイデアは諦めて、貴方が処理後はこういうフィルタをかけておきたい、という事をコーディングしてはいかがでしょうか。そして、そのコードは、マクロの自動記録で得られると思いますよ。
（???） 2017/11/28(火) 09:56
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.