[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『「VBA」A列とB列を比較し、差分の項目を表示させたい』（ぎん）
長くなったのでこの前のものは削除致しました。（内容は残しております）
回答頂きました（β）様、（???）様本当にありがとうございました＞
「商品あ」と「商品い」を比較し、差分が生じた行をメッセージボックスで表示させると言う事の構文を教えて頂きました。
依頼された担当に伝えたところ、行数だけを知るのではなくその行に書かれている項目（タグ）も表示させて欲しいと言われました。
（「商品あ」には入っていて「商品い」には入っていないタグを探したい）
＜文字入力されていないセルは空白セルです。＞
罫線がつけれないので分かりにくいのですが空白セルのC1〜F3まで「データ1」の情報、D2〜F3までが「aaa」の情報、E3〜F3までが「bbb」の情報が存在しています。
（E列3行目にある「bbb」は本来「データ1」の中にある「aaa」の中にある「bbb」を示しています。
ファイルツリーのようにD列が「データ1」の下の階層。E列は「aaa」の下の階層。と言う感じです。
A B C D E F
1商品あ 商品い データ1
2 ○ ○ aaa
3 ○ × bbb
4 ○ ○ データ2
5 ○ ○ aaa2
6 ○ ○
7 ○ ○ bbb2
（各行にはC列以降に文字が必ず入っているとは限りません）
（表が崩れて表示されている可能性があります。みにくくてすみません）
C列の「データ1」は「商品あ」「商品い」の中に入っている「タグ」です。C列以下はすべて「タグ」の名前が入力されています。「aaa」「bbb」もタグ名です。
C1「データ1」は親項目に当たります。（C列は親項目の入力のみになります）
「商品い」の3行目に差分があるので、その時に表示させたい内容は
「データ1」、「aaa」、「bbb」のようにです。
＊差分のある行のC列を基準に右に見ていき、空白セルがなくなったところの文字を拾う。
C列まで戻ってみた時に空白のセルがあればその上のセルを探し、空白セルがなくなったところの文字を拾う。
C列に当たるまで繰り返す。
と言う事をイメージしているのですが、そういう事が可能なのか否かも私には分からない範疇です・・・
自分の能力（知識）を完全に超えてしまっておりまして出来る、出来ない。
何をやりたいのか分からない。など厳しいお言葉もお願い致します。
友人に知恵を借り下記のコードを考えて貰いましたが、
親のタイトルを取得する事なら出来るかもしれない。と言う事で下記のコードを作ってくれましたが表示が出来ませんでした。
知恵をお貸し下さい。
以下コードです。
Option Explicit
Private Const MaxColumn As Long = 200 ' これ以上見に行かない境界線
' 差分不一致が出た行から、
' 対応するデータの親タイトルを取得する
' 不一致が出た行に対応するデータの座標を返す関数
Private Sub DirectionOfTargetData(ByRef x As Long, ByRef y As Long, ByVal i As Long)
' x : 対応するデータのＸ座標 （戻り値用）
' y : 対応するデータのＹ座標 （戻り値用）
' i : 差分不一致があった行
Dim TS As Worksheet ' TargetSheet（オブジェクトの明示）
Set TS = ThisWorkbook.Worksheets("Message")
y = i
x = 3 ' C列に相当
' ｉ行の3列（C列）から順番に右を見て行って、
' 空白でないセルを見つけたらループを抜ける
Do
If TS.Cells(y, x).Value <> "" Then Exit Do
x = x + 1
' 一向に空白でないセルが見つからない場合、 ' 見つからなかったことを示す Ｘ＝−１ を返す
If x > MaxColumn Then
x = -1
Exit Do
End If
Loop
End Sub
' 指定データの座標から、１階層上のデータの座標を返す関数
' 不一致が出た行に対応するデータの座標を返す関数
Private Sub SearchParentDirection(ByRef x As Long, ByRef y As Long)
' x : 指定データのＸ座標
' y : 指定データのＹ座標
Dim TS As Worksheet ' TargetSheet（オブジェクトの明示）
Set TS = ThisWorkbook.Worksheets("Message")
' 手違いで３列目より若い列の座標を受け取っていたら
' データではないので見つからないことを示す Ｘ＝−１を返す
If x < 3 Then
x = -1
Exit Sub
Else
x = x - 1 ' 照準を１つ前の列に移す
End If
' 手違いで１行目の座標を受け取っていたら
' これ以上遡れないので、見つからないことを示す Ｙ＝−１を返す
If y = 1 Then
y = -1
Exit Sub
End If
' 指定データの前の列のＹ行から順番に上を見て行って、
' 空白でないセルを見つけたらループを抜ける
Do
If TS.Cells(y, x).Value <> "" Then Exit Do
y = y - 1
' 一番上（１行目）まで行っても空白でないセルが見つからない場合、 ' 見つからなかったことを示す Ｙ＝−１ を返す
If y < 1 Then
y = -1
Exit Do
End If
Loop
End Sub
' 不一致を出したデータの属するタイトルを返す関数
Public Function SearchTitle(ByVal i As Long) As String
' ｉ： 差分不一致の行
Dim x As Long ' タイトルのＸ座標
Dim y As Long ' タイトルのＹ座標
Dim TS As Worksheet ' TargetSheet（オブジェクトの明示）
Set TS = ThisWorkbook.Worksheets("Message")
' 初期化
x = 0
y = 0
' 差分不一致に対応するデータの座標を取得
Call DirectionOfTargetData(x, y, i)
Do
' 見つからない事を示す −１ が返ってきたら、
' メッセージを表示して終了する
If x = -1 Or y = -1 Then
MsgBox ("サーチに失敗しました。" & vbCrLf & _
"データに欠けがある可能性があります。")
SearchTitle = "取得失敗"
Exit Do
End If
' 列座標が3（C列）になったら、そのセルに求めたタイトルがあるので、
' そのセルの内容を返して終了する
If x = C Then
SearchTitle = TS.Cells(y, x).Text
Exit Do
End If
' １階層上のデータの座標を取得
Call SearchParentDirection(x, y)
Loop
End Function
長々と申し訳ありません
（ぎん） 2015/09/03(木) 15:51
ごめんなさい。回答ではありません。
>>長くなったのでこの前のものは削除致しました。（内容は残しております）
ぎんさんは【内容を残してある】ので大丈夫でしょうけど、βは、そのようなことをしておりませんので さて、いったい、どんな回答をしたのかな？まとはずれな回答をしたんじゃないかな？ などと いろいろ思ってしまいます。
掲示板に寄せられた回答は、ぎんさんだけの所有物ではなく、回答者の財産でもありますし また、掲示板を閲覧するすべての人の財産でもあります。
次回からでいいですが、このような場合は、新規で追加トピをたてる。 で、そのトピに、以下のように、このトピの参照ができるようにしておく。
[[20150901182928]] 『「VBA」A列とB列を比較し、差分の項目を表示させａx（ぎん）
そうされることをおすすめします。
（β） 2015/09/03(木) 16:07
仰られている通りです。失礼いたしました。
今後利用させて頂く際にはそのように行います。
ご指摘ありがとうございました。
（ぎん） 2015/09/03(木) 16:22
ところで、データ1 は 1行目なんですか？ 意味としてはわかりますし、処理コードもかけますけど、データ1 が 1行目ということは 商品あ のレベルに データ1 が割り振られている？ そうすると、その商品あ の一部分である4行目、これは下層階層だと思われますが、同じレベルのデータ2？
データの構成の理解のために、ここのところを、もう少し教えてもらえますか？
（β） 2015/09/03(木) 16:24
追加で。
確か前は ○Ｘ ないしは Ｘ○ を抜き出したと思うんですが、今回は、B列が × のものだけを対象にするんですね？
（β） 2015/09/03(木) 16:28
元の質問は絶対消しては駄目！ 質問したのは貴方であり、貴方の著作ですが、回答は各回答者の著作。
消して良いのは自分の分だけ。 しかし、Q&Aなのだから、質問なしに回答だけでは成り立たないので、
合わせて成果物と考えると、一度書いたものは自分のも他人のも消しては駄目、ということになります。
長くなって質問を改める場合、新しく質問するのはOK。その中で前の質問はこれ、と、リンクを用意しましょう。
でもって、コーディングですが、無駄に関数でこねくり回していて、何がしたいのかさっぱりです。
InputとOutputを、実例を挙げて明確にしてください。
（InputはだいたいOKですが、F列を用意していながら、使っていないような？）
aaaとかbbbではなく、元の数字や半角全角等、型は一致しているけど内容が違うくらいの、それっぽい例でお願いします。
（適当な例だと、後から実はこういう…、等と、そのままでは絶対使えないような再質問が出やすいです）
あと、コーディングは無駄な改行（意味のある改行はOK）を無くし、段付けを整える。
Option Explicitを使っているのに、宣言していない変数を使ってはだめ。そのままコピペして動く状態にしてください。
現在のコードでは、関数が3つありますが、メインのプロシジャが見当たりませんよ？
（???） 2015/09/03(木) 16:32
A B C D E F
1 項目
2 商品あ 商品い
3 ○ ○ App〜
4 ○ × Function
5 ○ ○ Application
6 ○ ○ Info〜
7 ○ ○ Version
8 ○ ○ Res
「商品あ」が旧バージョンで、「商品い」が新バージョン。
「商品あ」には入れていたタグを「商品い」では入れていないタグがあればそれを表示させたいです。
（ぎん） 2015/09/03(木) 16:43
Sub test()
Dim i As Long
Dim iMax As Long
Dim j As Long
Dim cw As String
With Sheets("Message")
iMax = .Cells(.Rows.Count, "A").End(xlUp).Row
For i = 2 To iMax
If .Cells(i, "A").Value <> .Cells(i, "B").Value Then
cw = ""
For j = 3 To 6
cw = cw & .Cells(i + 1, j).End(xlUp).Value & " "
Next j
MsgBox cw, vbInformation, i & "行目"
Exit For
End If
Next i
End With
End Sub
（???） 2015/09/03(木) 16:46
コーディングですが、友人もまだ勉強中でとは言っておりましたが
分かる方に見て頂くとちゃんと出来ていなかったのですね。
コードはそのままコピペしました。
改行は多かったですが、そういうものなのかと思っておりました。
改良は出来ますでしょうか？
すみません、コメントが行き違っておりました！
（ぎん） 2015/09/03(木) 16:49
推測のレイアウトをアップしようとしていましたら、改訂版レイアウト提示がありましたね。
・対象は Ｂ列の× だけですね？（前とは違うんですね？） ・ところで、商品なんですが、このシートの２行目に存在するだけですか？ つまり、このシートは商品あ だけのシートと考えていいのですか？ それとも、下のほうに、商品え といったものが登場するレイアウトなんですか？ 後者であれば、メッセージに商品名もださないと、どの商品の部品か、わからなくなると思いますので。
（β） 2015/09/03(木) 16:50
商品が2つだけ、というはずはないと思うので、私も次の商品がどこに出てくるのか気になりますね。
いまのコーディングだと、A列B列違いだけ見ているから、商品名違いにも反応してしまうという。
（???） 2015/09/03(木) 16:52
メッセージボックスにて、差分のある行数、項目を表示出来たらと思っています。
現在商品の比較は2つだけでと言われています。
表の行数が誤っておりました。失礼いたしました。
（β）様
>・対象は Ｂ列の× だけですね？（前とは違うんですね？） 前回の表とは違って作っております。
>・ところで、商品なんですが、このシートの２行目に存在するだけですか？ >つまり、このシートは商品あ だけのシートと考えていいのですか？ >それとも、下のほうに、商品え といったものが登場するレイアウトなんですか？ >後者であれば、メッセージに商品名もださないと、どの商品の部品か、わからなくなると思いますので。
現在商品比較は2つだけだと言われております。
（ぎん） 2015/09/03(木) 16:57
Sub test2()
Dim i As Long
Dim cw As String
With Sheets("Message")
For i = 3 To .Cells(.Rows.Count, "A").End(xlUp).Row
If .Cells(i, "A").Value <> .Cells(i, "B").Value Then
cw = .Cells(i, "C").End(xlUp).Value & vbLf & _
.Cells(i, "B").End(xlToRight).Value
MsgBox cw, vbInformation, i & "行目"
Exit For
End If
Next i
End With
End Sub
（???） 2015/09/03(木) 17:31
End(xlUp)というのは、CTRL+↑を押下したのと同じ動作、
End(xlToRight)は、CTRL+→と同じ動作です。
差のある行のC列をクリック後、上記のキー入力を試してみてください。
それと同じ動作を、コーディングで実現して、得られた値を表示しています。
（???） 2015/09/03(木) 17:37
test、test2とどちらも試してみました。
数値などを変えたものを置いてみます。
（差分を作り、IP列22行目に設定してみました）
A列→IK
B列→IP
C列→IT（列番号・254)
16行目から項目が入力されています
Sub test2()
Dim i As Long
Dim iMax As Long
Dim j As Long
Dim cw As String
With Sheets("Message")
iMax = .Cells(.Rows.Count, "IK").End(xlUp).Row
For i = 16 To iMax
If .Cells(i, "IK").Value <> .Cells(i, "IP").Value Then
cw = ""
For j = 254 To 256
cw = cw & .Cells(i + 1, j).End(xlUp).Value & " "
Next j
MsgBox cw, vbInformation, i & "行目"
Exit For
End If
Next i
End With
End Sub
こちらで望んでいるものが表示されました！！
本当にありがとうございます
（ぎん） 2015/09/03(木) 18:15
（ぎん） 2015/09/03(木) 18:17
9/4 4:27 コードリバイス。 メッセージ表示をなくし、シートへの結果転記のみにしました。
>>メッセージボックスじゃなく別のワークブックに表示させてほしいと言われました・
作業としては絶対にそうであるべきですよね。 じゃないと、一生懸命メモをとって、あとで、正しいかどうかの確認をしなきゃいけない。 別ブックか、同じブックの別シートかは別にして、シートに転記しておけば、時間があるときにゆっくりと仕事ができますからね。
コードとは別に、このような、運用面での仕組み設計もきわめて重要ですので、がんばってくださいね。
思い切りわかりにくいコードだとは思いますが一例。データの列数は自動判定しています。 元データが"Sheet1"、結果をメッセージするとともに、同じマクロブックの"Sheet2"に転記しています。
Sub Sample()
Dim c As Range
Dim r As Range
Dim a As Range
Dim x As Long
Dim cols As Long
Dim done As Boolean
Dim old As Variant
Dim cur As Variant
Dim v As Variant
Dim w As Variant
Dim shF As Worksheet
Dim shT As Worksheet
Set shF = Sheets("Sheet1")
Set shT = Sheets("Sheet2")
shT.UsedRange.ClearContents
cols = shF.Range("A1", shF.UsedRange).Columns.Count
For Each c In shF.Range("A3", shF.Range("A" & Rows.Count).End(xlUp))
Set r = c.EntireRow.Range("C1").Resize(, cols - 2)
If WorksheetFunction.CountA(r) = 1 Then
cur = r.Value
If Not done Then
done = True
Else
For x = 1 To UBound(cur, 2)
If Not IsEmpty(cur(1, x)) Then Exit For
cur(1, x) = old(1, x)
Next
End If
old = cur
If c.Value <> c.Offset(, 1).Value Then
If IsArray(v) Then
ReDim Preserve v(1 To UBound(v) + 1)
ReDim Preserve w(1 To UBound(w) + 1)
Else
ReDim v(1 To 1)
ReDim w(1 To 1)
End If
v(UBound(v)) = cur
w(UBound(w)) = c.Row & "行目"
End If
End If
Next
If IsArray(v) Then
shT.Range("A1").Resize(UBound(v)).Value = WorksheetFunction.Transpose(w)
shT.Range("B1").Resize(UBound(v), r.Columns.Count).Value = WorksheetFunction.Transpose(WorksheetFunction.Transpose(v))
Else
shT.Range("A1").Value = "差異はありません"
End If
shT.Select
End Sub
（β） 2015/09/03(木) 21:00
↑
>>A列→IK >>B列→IP >>C列→IT（列番号・254) >>16行目から項目が入力されています
これには対応していません。もちろん対応可能ですが。
（β） 2015/09/04(金) 08:10
データ領域の変更対応バージョンです。 領域規定は先頭の
Const COMC1 As String = "IK"
Const COMC2 As String = "IP"
Const LISTC As String = "IT"
Const DATAROW As Long = 16
ここで行っています。レイアウト変更に合わせて、ここを直すだけで、あとはＯＫです。
Sub Sample2()
Const COMC1 As String = "IK"
Const COMC2 As String = "IP"
Const LISTC As String = "IT"
Const DATAROW As Long = 16
Dim c As Range
Dim r As Range
Dim a As Range
Dim x As Long
Dim cols As Long
Dim done As Boolean
Dim old As Variant
Dim cur As Variant
Dim v As Variant
Dim w As Variant
Dim shF As Worksheet
Dim shT As Worksheet
Set shF = Sheets("Sheet1")
Set shT = Sheets("Sheet2")
shT.UsedRange.ClearContents
cols = shF.Range("A1", shF.UsedRange).Columns.Count
For Each c In shF.Range(COMC1 & DATAROW, shF.Range(COMC1 & Rows.Count).End(xlUp))
Set r = c.EntireRow.Range(LISTC & 1).Resize(, cols - Columns(LISTC).Column + 1)
If WorksheetFunction.CountA(r) = 1 Then
cur = r.Value
If Not done Then
done = True
Else
For x = 1 To UBound(cur, 2)
If Not IsEmpty(cur(1, x)) Then Exit For
cur(1, x) = old(1, x)
Next
End If
old = cur
If c.EntireRow.Range(COMC1 & 1).Value <> c.EntireRow.Range(COMC2 & 1).Value Then
If IsArray(v) Then
ReDim Preserve v(1 To UBound(v) + 1)
ReDim Preserve w(1 To UBound(w) + 1)
Else
ReDim v(1 To 1)
ReDim w(1 To 1)
End If
v(UBound(v)) = cur
w(UBound(w)) = c.Row & "行目"
End If
End If
Next
If IsArray(v) Then
shT.Range("A1").Resize(UBound(v)).Value = WorksheetFunction.Transpose(w)
shT.Range("B1").Resize(UBound(v), r.Columns.Count).Value = WorksheetFunction.Transpose(WorksheetFunction.Transpose(v))
Else
shT.Range("A1").Value = "差異はありません"
End If
shT.Select
End Sub
（β） 2015/09/04(金) 08:43
担当より最終的な理想を伝えられましたので、箇条書きですがまとめます。
＊商品の一覧が記載されているファイルとは別に、差分検出したものをまとめる為のファイルを作成（差分検出ファイルとします）
＊ネットワーク上に比較対象となるファイルが多数あるので（聞いていませんでした）、そのファイルも差分検出ファイルより呼び出したい。
（多数ファイルがあるが、比較対象となる「商品あ」「商品い」の名前はどのファイルでも共通。）
＊比較したいファイルを呼び出し、差分検出ファイルに「比較開始ボタン」のようなものを設置し、ボタンを押す事で差分比較開始。
差分が生じた際には差分検出ファイルに反映させる。
という流れを昨晩伝えられました。
ネットワーク上にあるファイルを呼び出すと言う事はなんとなく分かるのですが
（実際には対象のファイルがあるフォルダを呼び出すように設定するつもりです）
差分比較する際に「列」「行」を指定せず、「単語（ワード）」を指定して検出させる事は可能でしょうか？
（β）様に上記のコードを頂いた後での事で申し訳御座いません。
担当にもゴールはもうすぐだ！と言われましたが、私には全くゴールが見えていません・・・
（ぎん） 2015/09/04(金) 10:40
確認です。
・現在見えているシート（商品あ、いの部品組替リスト）を持つブックが複数あるということですか？ ・で、どのブックも、このシートのレイアウトは同じ？ ・それらブックについてすべて処理？ ・処理結果はどこに（差分検索ファイルでしょうけど）どのようなレイアウトでセットしたいのですか？ あるブックの あ と い の比較は これこれ、別のブックの あ と い の比較は これこれ、また別のブックの あ と い の比較は・・・ とした場合、それらを、どのようなレイアウトで差分検索ファイルに書きこむのですか？ 具体例をイメージでアップいただけるとありがたいですね。 ・それら複数のブックの処理、これは一括で行うのですか？ それとも、今回はどのブックというように 操作者が指定するのですか？（後者であれば、セット条件は今と同じでしょうから前項の質問はなくなりますが） 前者なら、それらは、どこかのフォルダにまとめて保存されているのですか？
>>差分比較する際に「列」「行」を指定せず、「単語（ワード）」を指定して検出させる事は可能でしょうか？
勘違いを避けるために、具体例で要件を説明いただけますか？
（β） 2015/09/04(金) 12:05
＞・現在見えているシート（商品あ、いの部品組替リスト）を持つブックが複数あるということですか？
→はい、確認しましたら13個ありました。
・で、どのブックも、このシートのレイアウトは同じ？
→レイアウト同じで、検索対象の列も同じでした。
「商品あ」IK列
「商品い」IP列
「項目開始列」IT列16行目
＞・それらブックについてすべて処理？
→はい。全て同じ処理です
＞・処理結果はどこに（差分検索ファイルでしょうけど）どのようなレイアウトでセットしたいのですか？
＞あるブックの あ と い の比較は これこれ、別のブックの あ と い の比較は これこれ、また別の>ブックの あ と い の比較は・・・
＞とした場合、それらを、どのようなレイアウトで差分検索ファイルに書きこむのですか？
＞具体例をイメージでアップいただけるとありがたいですね。
「差分検索ファイル」としまして（以下差分ファイルを称します）「差分ファイル（シート1）」のA列1行目より比較検証するファイル名（13個）を羅列します。
１つ1つのファイル名の間を10行取る予定です。
A列1行目に「差分」と入力し
A列2行目「Message1」
A列12行目「Message2」
A列22行目「Message3」のファイル名を記載（以下13個分のファイル名を記載していきます）
B列2行目に「Message1」にて比較検証を行い、差分が生じた項目を転記 フルパスのように「AppReqExrXXXXX->Result」のイメージ。
（多分10項目も差分が生じる事は少ないだろうと担当者の意見でしたので、10行間を設けます）
「差分ファイル（シート2）」にて確認対象の13個のファイルを呼び出せるようにしたいと言われました。
（フォルダを開くようにしたかったのですが、うまくいかなかったので各ファイルを呼び出すように考えてます）
Workbooks.Open fileName:="\\共有サーバー\共有\TEST.xls"（例）
＞・それら複数のブックの処理、これは一括で行うのですか？ それとも、今回はどのブックというように
＞操作者が指定するのですか？（後者であれば、セット条件は今と同じでしょうから前項の質問はなくなりますが）
＞前者なら、それらは、どこかのフォルダにまとめて保存されているのですか？
→こちらは、担当者が各ブックを指定し１つずつ操作します。
ブックはネットワーク上のフォルダ内にまとまって保存されています。
＞＞＞差分比較する際に「列」「行」を指定せず、「単語（ワード）」を指定して検出させる事は可能でしょうか？
＞勘違いを避けるために、具体例で要件を説明いただけますか？
→すみません、私の勘違いでした。
（複数検証対象ファイルが増えた為に「商品あ」「商品い」の入力されている列がファイルによって変わってしまうと思っておりましたが、どのファイルも全く同じレイアウトでした）
こちらに関してはスルーして頂いて結構です。失礼いたしました。
（ぎん） 2015/09/04(金) 13:42
上記にて頂いたこちらのコードを変えたら出来るかも。と思ったのですが
Workbooks(ワークブックのファイル名). Sheets("Sheet1"）にすると13個のファイルに対応は出来ませんよね・・・。
Set shF = Sheets("Sheet1")
Set shT = Sheets("Sheet2")
shT.UsedRange.ClearContents
（ぎん） 2015/09/04(金) 14:14
なんとなく、わかってきました。 ただ、説明内に理解しきれないところ等があります。
>>「差分ファイル（シート1）」のA列1行目より比較検証するファイル名（13個）を羅列します。 とうことですが、アップされたサンプルは 1行目が "差分"、2行目が Message1、12行目がMessage2、・・・ A列1行目からファイル名が羅列されているのは差分ファイル（シート2）じゃないんですか？
>>「差分ファイル（シート2）」にて確認対象の10個のファイルを呼び出せるようにしたいと言われました。 比較検証するファイルは 13個？10個?
ここは固定せず、いくつでも指定可能にしておくこともできますし、あるいは、フォルダが決まっていれば そのフォルダから自動抽出もできますよ。さらに、そのフォルダ自体を、ここだと選択させることもできます。
仮に、シート上でブックを指定する場合、フルパス（\\共有サーバー\共有\TEST.xls) で指定してもらう必要がありますが大丈夫ですか？
>>フォルダを開くようにしたかったのですが、うまくいかなかったので
どのように、うまくいかなかったのですか？
>>多分10項目も差分が生じる事は少ないだろうと担当者の意見でしたので、10行間を設けます
あまり、このような仕様は好きじゃないです。コードとしては、制限チェックをしなければならないので、 よけいに手間がかかります。（たいした手間ではないですが） 差分が1つなら1つだけ、20あれば20 を表示するようにしてはいかがですか？
>>その為、比較検証する対象を「商品あ」「商品い」と入力されている列を比較対象と出来るかどうか。です。
はい。できますよ。どのように、この ２つを指定したいか、「担当さん」のイメージを聞いていただけますか？ これでいいだろうと作っても、その「担当さん」から、「あぁ、おしいねぇ。こういったようにやりたかったんだよ」なんて言われると ちょっと、やるせないので。 それと、データ領域（現在でいえば IT列17行目) は、どのように指定する予定ですか？（その「担当さん」の予定）
なお、場所に指定は、検索文字列を指定して見つける方法もありますが、マウスで、ここだ と選んでもらうこともできますよ。
それはそれとして、以下のような流れ・構成なのかなと思います。イメージあってますか？
１．マクロブックは、差分検索ファイル ２．差分検索ファイルにあるマクロを動かして、このブックのしかるべきシートに結果を転記 ３．処理の流れは １）まず、比較すべき商品が記載されているブックを操作者がブック選択画面で１つ選ぶ。 ２）マクロで、選ばれたブックを開く。 ３）商品あ、商品い、データ項目領域 を把握するための ３つの文字列を操作者に指定させる。 ないしは、３つの場所を操作者にマウスで選択させる。 ４）開いたブックが間違いだった、ということに備え、この段階でのキャンセルも受け付ける。 ５）指定された文字列が発見されたら、今までアップしたロジックを使い、差分検索ファイル内のシートに結果を転記。 こんなことであってますか？
（β） 2015/09/04(金) 14:16
＞＞＞「差分ファイル（シート1）」のA列1行目より比較検証するファイル名（13個）を羅列します。
＞とうことですが、アップされたサンプルは 1行目が "差分"、2行目が Message1、12行目がMessage2、・・・＞ A列1行目からファイル名が羅列されているのは差分ファイル（シート2）じゃないんですか？
→「差分ファイル（シート2）」はただネットワーク上にあるファイルを出すのが手間だからこの作業を全て「差分ファイル」にて行いたいという要望でした。
実際に差分を表示させるのは（シート1）にまとめたい。
＞＞＞「差分ファイル（シート2）」にて確認対象の10個のファイルを呼び出せるようにしたいと言われました。
＞比較検証するファイルは 13個？10個?
→すみません、13個です。
＞ここは固定せず、いくつでも指定可能にしておくこともできますし、あるいは、フォルダが決まっていれば
＞そのフォルダから自動抽出もできますよ。さらに、そのフォルダ自体を、ここだと選択させることもできます。
＞仮に、シート上でブックを指定する場合、フルパス（\\共有サーバー\共有\TEST.xls) で指定してもらう必要がありますが大丈夫ですか？
→フォルダは決まっておりますが、13個のファイルのうち3つは階層が異なっています。
\\共有サーバー\共有\作業\10個
\\共有サーバー\共有\作業\other\3つ
フルパスで表示させるのは出来ました。
（テストで表示させ、ファイルを開く事まで出来ました）
＞＞＞フォルダを開くようにしたかったのですが、うまくいかなかったので
＞どのように、うまくいかなかったのですか？
→ローカルのフォルダは開けたのですが、ネットワークの設定が出来ませんでした。（IPを入力してみました）
＞＞＞多分10項目も差分が生じる事は少ないだろうと担当者の意見でしたので、10行間を設けます
＞あまり、このような仕様は好きじゃないです。コードとしては、制限チェックをしなければならないので、
＞よけいに手間がかかります。（たいした手間ではないですが）
＞差分が1つなら1つだけ、20あれば20 を表示するようにしてはいかがですか？
→行数に関しては必ずしも何行あけなければならない！とは言われていませんので余裕をもって20の表示をお願いします。
＞＞＞その為、比較検証する対象を「商品あ」「商品い」と入力されている列を比較対象と出来るかどうか。です。
＞はい。できますよ。どのように、この ２つを指定したいか、「担当さん」のイメージを聞いていただけますか？
＞これでいいだろうと作っても、その「担当さん」から、「あぁ、おしいねぇ。こういったようにやりたかったんだよ」なんて言われると
＞ちょっと、やるせないので。
＞それと、データ領域（現在でいえば IT列17行目) は、どのように指定する予定ですか？（その「担当さん」の予定）
＞なお、場所に指定は、検索文字列を指定して見つける方法もありますが、マウスで、ここだ と選んでもらうこともできますよ。
→担当に確認しましたが、どのファイルも全て
「商品あ」IK列
「商品い」IP列
「項目開始列」IT列16行目
と同じでしたので「商品名」での検証は無くて大丈夫になりました。
（確認不足ですみません）
＞それはそれとして、以下のような流れ・構成なのかなと思います。イメージあってますか？
＞１．マクロブックは、差分検索ファイル
→あっています
＞２．差分検索ファイルにあるマクロを動かして、このブックのしかるべきシートに結果を転記
→あっています
＞３．処理の流れは
＞１）まず、比較すべき商品が記載されているブックを操作者がブック選択画面で１つ選ぶ。
→あっています
＞２）マクロで、選ばれたブックを開く。
→あっています
＞３）商品あ、商品い、データ項目領域 を把握するための ３つの文字列を操作者に指定させる。
＞ないしは、３つの場所を操作者にマウスで選択させる。
→こちらが「商品名」での検索ではなく、今までアップして頂いた列での検索になる為にこの動作は無くなります。
「商品あ」IK列
「商品い」IP列
「項目開始列」IT列16行目
比較対象となる13個のファイルを全て確認致しまして商品名、列、行が同じ事を確認。
＞４）開いたブックが間違いだった、ということに備え、この段階でのキャンセルも受け付ける。
→承知致しました。
★3）で商品選択が無くなりますので
選ばれたブックを開き、「差分検索ファイル」に「比較検証！」のようなボタンを設置し、ボタンを押下し差分比較を開始。と出来ますか？
（ボタンからプログラムの設定は出来ます）
＞５）指定された文字列が発見されたら、今までアップしたロジックを使い、差分検索ファイル内のシートに結果を転記。
→あっています。
私の行いたい事を文章だけで汲み取って頂けて本当に感謝致します。
（ぎん） 2015/09/04(金) 14:54
とりあえず、いちいちブックを選択したり、確認のために止まるのは作る方も使う方も面倒なので、ボタンを押したら全部処理する例。
Private Sub CommandButton1_Click()
Const cPATH = "\\共有サーバー\共有\作業\"
Dim wkOut As Worksheet
Dim i As Long
Dim j As Long
Dim iw As Long
Dim iR As Long
Dim cFiles As Variant
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set wkOut = Me
With wkOut
iw = .Cells(.Rows.Count, "A").End(xlUp).Row
If 1 < iw Then
.Rows("2:" & iw).Delete
End If
End With
iR = 1
cFiles = Split(CreateObject("WScript.Shell").Exec("CMD /C DIR /A:-D/B/S """ & cPATH & "*.xls*""").StdOut().ReadAll(), vbNewLine)
For i = 0 To UBound(cFiles) - 1
With Workbooks.Open(cFiles(i), False, True)
With .Sheets(1)
For j = 16 To .Cells(.Rows.Count, "IK").End(xlUp).Row
If .Cells(j, "IP").Value = "×" Then
iR = iR + 1
wkOut.Cells(iR, "A").Value = cFiles(i)
wkOut.Cells(iR, "B").Value = j
wkOut.Cells(iR, "C").Value = .Cells(j, "IT").End(xlUp).Value
wkOut.Cells(iR, "D").Value = .Cells(j, "IT").End(xlToRight).Value
End If
Next j
End With
.Close
End With
Next i
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
（???） 2015/09/04(金) 15:32
お叱りを受ける事は重々承知しております。
皆様にお願いしている状態です。
やりたい事を一つずつ調べてみましたが理解出来ず。
（???）様、（β）様のお気持ちに完全に甘えてしまい本当に申し訳御座いません。
上記のコードを頂きましてありがとうございます！
感謝致します！！
（ぎん） 2015/09/04(金) 15:46
個人的には、(???)さんの処理のように、フォルダ階層から該当のファイルを抽出して処理が好みですが フォルダ内に対象外ブックがあるのかどうかといったあたりも不明なので、とりあえず、そちらの指定の ・このマクロブックの"Sheet1"のA1からずらっと必要ファイルのフルパスが記載されている。（1つでも10でも100でも必要なだけ） ・比較結果は、このマクロブックの"Sheet2"に転記。転記レイアウトは、そちらの要望とは異なるけど、βの提案として。 差分行数だけ、差分がひょうじされる。（100行の差分があれば100行。1行しかなければ1行)
試してください。
Sub Sample3()
Const COMC1 As String = "IK"
Const COMC2 As String = "IP"
Const LISTC As String = "IT"
Const DATAROW As Long = 16
Dim wR As Range
Dim c As Range
Dim r As Range
Dim a As Range
Dim x As Long
Dim cols As Long
Dim done As Boolean
Dim old As Variant
Dim cur As Variant
Dim v As Variant
Dim shF As Worksheet
Dim shT As Worksheet
Dim shW As Worksheet
Dim pos As Range
Application.ScreenUpdating = False
Set shW = ThisWorkbook.Sheets("Sheet1")
Set shT = ThisWorkbook.Sheets("Sheet2")
shT.UsedRange.ClearContents
shT.Range("A1:B1").Value = Array("差分", "項目")
For Each wR In shW.Range("A1", shW.Range("A" & Rows.Count).End(xlUp))
If Dir(wR.Value) <> "" Then
Set shF = Workbooks.Open(wR.Value).Sheets(1)
v = Empty
done = False
cols = shF.Range("A1", shF.UsedRange).Columns.Count
For Each c In shF.Range(COMC1 & DATAROW, shF.Range(COMC1 & Rows.Count).End(xlUp))
Set r = c.EntireRow.Range(LISTC & 1).Resize(, cols - Columns(LISTC).Column + 1)
If WorksheetFunction.CountA(r) = 1 Then
cur = r.Value
If Not done Then
done = True
Else
For x = 1 To UBound(cur, 2)
If Not IsEmpty(cur(1, x)) Then Exit For
cur(1, x) = old(1, x)
Next
End If
old = cur
If c.EntireRow.Range(COMC1 & 1).Value <> c.EntireRow.Range(COMC2 & 1).Value Then
If IsArray(v) Then
ReDim Preserve v(1 To UBound(v) + 1)
Else
ReDim v(1 To 1)
End If
v(UBound(v)) = cur
End If
End If
Next
If IsArray(v) Then
Set pos = shT.Range("B" & Rows.Count).End(xlUp).Offset(1)
pos.Offset(, -1).Value = shF.Parent.Name
pos.Resize(UBound(v), r.Columns.Count).Value = WorksheetFunction.Transpose(WorksheetFunction.Transpose(v))
End If
shF.Parent.Close False
End If
Next
shT.Select
End Sub
（β） 2015/09/04(金) 17:45
本当に感謝致します。
ここまでして頂きましてありがとうございます！！
書かれている内容がどの指示がどういった事を指しているのかを理解していきます。
お二方とも本当にありがとうございました。
今後は自分の能力が無い事を担当へ伝えゆっくりと学んでいきます。
お二方のお時間頂きました事に感謝致します。
有難うございました。
（ぎん） 2015/09/04(金) 19:56
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.