[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『フィルタで絞り込んだ行に対して処理を行う。』（u）
こんばんは。
フィルタで絞り込んだ行に対して処理を行うコードについて困っています
fNmTx = ThisWorkbook.Path & "\出庫リスト\" & iDx(i)(2) & ".xlsx"
If zWbExists(fNmTx) Then
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Dim dstWS1 As Worksheet
Set dstWS1 = ThisWorkbook.Worksheets("機種間共通部品検索")
Dim srcWS1 As Workbook
Set srcWS1 = Workbooks.Open(fNmTx)
With srcWS1.Worksheets(1)
Dim c As Range
With srcWS1.Worksheets(1)
srcWS1.Worksheets(1).Range("B6:AJ359"). _
AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:=dstWS1.Range("D6:E7"), _
Unique:=True
For Each c In .AutoFilter.Range.SpecialCells(xlCellTypeVisible)
x = Application.Match(iDx(i)(3), srcWS1.Worksheets(1).Range("B:B"), 0)
If Not IsError(x) Then
.Cells(x, "A") = tMp(5)
srcWS1.Worksheets(1).Cells(x, "A").EntireColumn.AutoFit
.Cells(x, "C") = dAtaBk
dAtaBk = ""
End If
Next c
End With
End With
srcWS1.Close True
Set srcW1 = Nothing
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Else
MsgBox "行き先機種F Non" & Chr(13) & iDx(i)(2) & ".xlsx"
Exit For
End If
If i Mod 30 = 0 Then DoEvents
Next
Set zTb = Nothing
Erase v, iDx, tMp
End Sub
で行うと
For Each c In .AutoFilter.Range.SpecialCells(xlCellTypeVisible)
でエラー91対応方法（オブジェクト変数または With ブロック変数が設定されていません。）と出ます。
どこをどう直せばよいかわからないのでご教授いただけると幸いです。
＜ 使用 Excel：Excel2019、使用 OS：Windows10 ＞
With srcWS1.Worksheets(1)
.AutoFilter.Range〜
^^^^^^^↑^^^^^^^^
オートフィルタが設定されてないと取得できないと思いますが・・・
（もこな２） 2021/04/05(月) 21:41
それでもわからなければ、【マクロの記録】をつかって、「フィルタオプション」と「オートフィルタ」をそれぞれ設定してみて、どのような命令が記録されるか確認してください。
（もこな２） 2021/04/05(月) 21:55
ちなみに、マクロの記録でやった際のコードは
Range("A6:AN154").AdvancedFilter Action:=xlFilterInPlace, Unique:=False
でした。
（u） 2021/04/05(月) 22:09
こんばんは ＾＾ いや〜。。。どこかで見たことがあるコードだなぁ？？？？ とか、おもっていました。。。ハンドル名がおなじ方だったもので おやっ？とか思い、拝見させていただきました。＾＾； 無理やり、フイルター、かけなくても。。。テーブルにしておくのも 一手かも、何もせずとも、何時でもフイルター、かけれますよ。＾＾； （隠居じーさん） 2021/04/05(月) 22:27
（u） 2021/04/05(月) 22:40
フイルターをかけようとしているのは マクロの有る、既に開いているブックですか コードで開いて書き込むブックでしょうか。 変更されたコードを拝見していますと、何やら 矛盾を感じます。 （u） 2021/04/05(月) 22:40 のご説明ですと、フイルターをかけずとも、一意なキーを 作成して、条件文で、書込めば良いように思うのですが。 ファイルレイアウトが不明な為、これ以上は具体的な事は 申し上げられません。m(__)m （隠居じーさん） 2021/04/05(月) 23:13
|[A] |[B] |[C] |[D] |[E] |[F] |[G] |[H] |[I] |[J] |[K]
[2] | |棚番|引当数＋保|出庫数|理論戻入数|戻入数|仕損数|戻入場所 |所要量|上位品番 |投入工程
[3] | |A---| 100| | 0| 0| 0| | 100|ZY-33260000|マウント（裏）
[4] | |A151| | 200| 0| 0| 0| | 200|ZY-33260000|マウント（裏）
[5] | |A614| | 552| 452| 452| 0| | 100|ZY-33260000|マウント（裏）
[6] | |A615| 1659| 1459| 2918| 1259| -1659| | 200|ZY-33260000|マウント（裏）
[7] | |A633| 2822| | 2622| 2622| 0| | 200|ZY-33260000|マウント（裏）
[8] | |A686| 379| | 179| 179| 0| | 200|ZY-33260000|マウント（裏）
[9] | |A705| 1798| 2298| 3596| 1798| 0|HC-Y01A OMOTE(1LINE)| 500|ZY-33260000|マウント（裏）
[10]| |A901| | 1686| 1586| 1586| 0| | 100|ZY-33260000|マウント（裏）
[11]|HC-Y01A URA|A705| 1798| | 1298| 1298| 0| | 500|ZY-33260000|マウント（表）
[12]| |A727| | 117| 17| 17| 0| | 100|ZY-33260000|マウント（表）
[13]| |A894| | 992| 892| 892| 0| | 100|ZY-33260000|マウント（表）
[14]| |A900| | 1674| 1574| 1574| 0| | 100|ZY-33260000|マウント（表）
[15]| |AB62| | 1900| 1800| 1800| 0| | 100|ZY-33260000|マウント（表）
フィルタをかけようとしているのはコードで開いたブックです。
フィルタ条件はJ列とK列です。
J列は上位品番が入りますが、生産ファイルによって毎回違います。
K列はマウント(裏)、マウント(表)、マウントのうちどれか一つ入ります。
マクロが組み込んであるブックの機種間共通部品検索シートに配置してある上位品番と投入工程
は上位品番はD6セルに見出しD7セルに実際の品番、投入工程はE6セルに見出し、E7セルに実際の内容が入ります。配置間隔は13列間隔です。
昨日掲示したコードは試作段階ですので
AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:=dstWS1.Range("D6:E7"), _
dstWS1.Range("D6:E7"), _の異なります。
（u） 2021/04/06(火) 07:32
Rangeオブジェクト.AdvancedFilter ・・・・・フィルタオプション Rangeオブジェクト.AutoFilter ・・・・・オートフィルタ
↑のように、それぞれ【別もの】です。
なので、オートフィルタが設定されてないにも関わらず「srcWS1.Worksheets(1).AutoFilter.Range」を取得しようとしてもダメなのではというのが「2021/04/05(月) 21:41」の指摘の趣旨です。
開く前からオートフィルタが設定されているとかであれば話は変わりますので、そうであれば説明を追加されたほうが良いでしょう。
（もこな２） 2021/04/06(火) 07:34
（フィルタオプションはしてますけど）
あまり書き込むと、隠居じーさんさんのじゃまをしそうなので、一度だけ再掲します。
【マクロの記録】をつかって、「フィルタオプション」と「オートフィルタ」をそれぞれ設定してみて、どのような命令が記録されるか確認してください。
（もこな２ ） 2021/04/06(火) 08:52
おはようございます ＾＾ ご提示の表からは、同じ、棚番は、発見できませんし マクロブックのほうは ＞＞配置間隔は13列間隔です。 12列じゃなかったのですか。＾＾； 前回とレイアウトが変わっているなら ご提示のコードは使えないかと？？。。。m(_ _)m と私が思うだけで。。。 でも、フイルターかけて、うまく行くのなら、もこな2さんのご案内の通り お調べになって、フイルターかけてくださいね。 棚番とは本来、一意な物なのでは、 何が、どう、変更に、なって、何をどうすれば、良いのか、なかなか ピント、来ませんので、私は、ここまでと、させて戴きます。他の回答者 様の、アドバイスをお待ちください。また、閃きましたら、現れるかもしれません。 前回のコードに関して、ご不明な点が有れば、その箇所の説明を質問してください。 それに関しましては、できうる限りご説明させて戴きます。m(__)m （隠居じーさん） 2021/04/06(火) 10:10
ちょっと考えてみますね。m(__)m
（隠居じーさん） 2021/04/06(火) 12:05
|[C] |[D] |[E] |[F] |[G] |[H] |[I] |[J] |[K]|[L]|[M] |[N]|[O]|[P] |[Q] |[R] |[S] |[T] |[U] |[V] |[W] |[X]|[Y]|[Z] |[AA]
[1] |1機種名 | | | | | | | | | | | | | | |2機種目 | | | | | | | | |
[2] |HC-Y01A URA | | | | | | | | | | | | | | |HC-Y01A OMOTE(1LINE)| | | | | | | | |
[3] |現ファイル名|HC-Y01A(151A690R)100台| | | | | | | | | | | |現ファイル名|HC-Y01A(151A690R)100台| | | | | | | | | |
[4] |前機種 |上位品番 |投入工程 | | | | | | | | | | |前機種 |上位品番 |投入工程 | | | | | | | | |
[5] | | |マウント（裏） | | | | | | | | | | | | |マウント（表） | | | | | | | | |
[6] |行き先機種 |上位品番 |投入工程 | | | | | | | | | | |行き先機種 |上位品番 |投入工程 | | | | | | | | |
[7] | | |マウント（表） | | | | | | | | | | | | | | | | | | | | | |
[8] |現機種名 |HC-Y01A URA | | | | | |HC-Y01A URA| |→ | | | |現機種名 |HC-Y01A OMOTE(1LINE) | | | | | |HC-Y01A OMOTE(1LINE)| |→ | |
[9] | | | |現機種| | | | | | |次機種| | | | | |現機種| | | | | | |次機種|
[10]|前機種 |行き先機種名 |行き先機種ファイル |棚番 |結合 |現機種名 |部品名 |M |Z | |M |Ｚ | |前機種 |行き先機種名 |行き先機種ファイル |棚番 |結合 |現機種名 |部品名 |M |Z | |M |Z
[11]| | | |A--- |A---HC-Y01A URA|HC-Y01A URA| | | |→ | | | | | | |A162 |A162HC-Y01A OMOTE(1LINE)|HC-Y01A OMOTE(1LINE)|KPL-3015CGCK | 1| 2|→ | |
[12]| | | |A151 |A151HC-Y01A URA|HC-Y01A URA|FA5510N-D1-TE1 | 3| 28|→ | | | | | | |A203 |A203HC-Y01A OMOTE(1LINE)|HC-Y01A OMOTE(1LINE)|KPL-3015SURCK | 2|127|→ | |
[13]| | | |A614 |A614HC-Y01A URA|HC-Y01A URA|S1WB(A)60-7062 | 2| 13|→ | | | | | | |A219 |A219HC-Y01A OMOTE(1LINE)|HC-Y01A OMOTE(1LINE)|MP2565DN-C578-LF-Z | 2|132|→ | |
[14]| | | |A615 |A615HC-Y01A URA|HC-Y01A URA|TJ30S06M3L(T6L1,NQ | 3| 18|→ | | | |HC-Y01A URA | | |A705 |A705HC-Y01A OMOTE(1LINE)|HC-Y01A OMOTE(1LINE)|ERZVF2M470 | 3| 15|→ | |
[15]| | | |A633 |A633HC-Y01A URA|HC-Y01A URA|PS2381-1Y-F3-AX/L | 3| 25|→ | | | | | | |A727 |A727HC-Y01A OMOTE(1LINE)|HC-Y01A OMOTE(1LINE)|SHP1045P-F101A | 2|137|→ | |
[16]| | | |A686 |A686HC-Y01A URA|HC-Y01A URA|2SD1584-Z-E1-AZ L.Kﾗﾝｸ| 3| 22|→ | | | | | | |AE62 |AE62HC-Y01A OMOTE(1LINE)|HC-Y01A OMOTE(1LINE)|ERJ3EKF3602V | 2|130|→ | |
[17]| |HC-Y01A OMOTE(1LINE) |HC-Y01A(151A690R)100台|A705 |A705HC-Y01A URA|HC-Y01A URA|ERZVF2M470 | 3| 15|→ | 3| 15| | | | |A900 |A900HC-Y01A OMOTE(1LINE)|HC-Y01A OMOTE(1LINE)|LM2901DR | 2|134|→ | |
[18]| | | |A901 |A901HC-Y01A URA|HC-Y01A URA|MCZ5207SG-3072 | 2| 18|→ | | | | | | |AB62 |AB62HC-Y01A OMOTE(1LINE)|HC-Y01A OMOTE(1LINE)|D1FK60-5053 | 2|115|→ | |
[19]| | | |A909 |A909HC-Y01A URA|HC-Y01A URA|PS2801C-1-F3-A(PLP) | 3| 20|→ | | | |HC-Y01A URA | | |AB84 |AB84HC-Y01A OMOTE(1LINE)|HC-Y01A OMOTE(1LINE)|C1206X105K101T | 1| 13|→ | |
[20]| | | |A994 |A994HC-Y01A URA|HC-Y01A URA|MCZ5303SH-5072 | 3| 30|→ | | | |HC-Y01A URA | | |AC01 |AC01HC-Y01A OMOTE(1LINE)|HC-Y01A OMOTE(1LINE)|CC0603KRX7R9BB102 | 1| 9|→ | |
[21]| | | |AA14 |AA14HC-Y01A URA|HC-Y01A URA|CC0805KKX7R8BB475 | 1|123|→ | | | | | | |AZ14 |AZ14HC-Y01A OMOTE(1LINE)|HC-Y01A OMOTE(1LINE)|GRM188R71H273KA61D | 2|128|→ | |
[22]| | | |AA33 |AA33HC-Y01A URA|HC-Y01A URA|DZ2W30000L | 1|118|→ | | | |HC-Y01A URA | | |AD02 |AD02HC-Y01A OMOTE(1LINE)|HC-Y01A OMOTE(1LINE)|ERJ3GEYJ103V | 1| 11|→ | |
[23]| | | |AA43 |AA43HC-Y01A URA|HC-Y01A URA|RC0603JR-0727K | 1| 37|→ | | | |HC-Y01A URA | | |AT68 |AT68HC-Y01A OMOTE(1LINE)|HC-Y01A OMOTE(1LINE)|ERJ3EKF3301V | 1| 28|→ | |
[24]| | | |AA70 |AA70HC-Y01A URA|HC-Y01A URA|RC0603FR-07820R | 1|110|→ | | | |HC-Y01A URA | | |AS88 |AS88HC-Y01A OMOTE(1LINE)|HC-Y01A OMOTE(1LINE)|ERJ3EKF4702V | 1|114|→ | |
[25]| | | |AB32 |AB32HC-Y01A URA|HC-Y01A URA| | | |→ | | | | | | |AT14 |AT14HC-Y01A OMOTE(1LINE)|HC-Y01A OMOTE(1LINE)|ERJ3EKF3302V | 2|117|→ | |
[26]| | | |AB37 |AB37HC-Y01A URA|HC-Y01A URA|ERJ3EKF2702V | 1| 6|→ | | | | | | |AT28 |AT28HC-Y01A OMOTE(1LINE)|HC-Y01A OMOTE(1LINE)|ERJ6GEYJ563V | 2|126|→ | |
[27]| | | |AB38 |AB38HC-Y01A URA|HC-Y01A URA|ERJ6GEYJ1R0V | 1|125|→ | | | | | | |A894 |A894HC-Y01A OMOTE(1LINE)|HC-Y01A OMOTE(1LINE)|DF13EA-30DP-1.25V(51)| 2|122|→ | |
[28]| | | |AB52 |AB52HC-Y01A URA|HC-Y01A URA|CC1206JKNPOZBN471 | 1|128|→ | | | |HC-Y01A URA | | |AC14 |AC14HC-Y01A OMOTE(1LINE)|HC-Y01A OMOTE(1LINE)|CC0603KRX7R9BB103 | 2| 25|→ | |
[29]| | | |AB78 |AB78HC-Y01A URA|HC-Y01A URA|ERJ6ENF6803V | 2| 3|→ | | | |HC-Y01A URA | | |AY90 |AY90HC-Y01A OMOTE(1LINE)|HC-Y01A OMOTE(1LINE)|GRM31BR73A102KW01L | 1|129|→ | |
現状のコードも掲示ます
Private Sub CommandButton1_Click()
Application.ScreenUpdating = False
Const zProgramID As String = "機種間共通部品,Z軸検索改良版??7.xlsm"
Dim zTb As Workbook
Dim i As Long
Dim j As Long
Dim n As Long
Dim v() As Variant
Dim tMp() As Variant
Dim iDx() As Variant
Dim leadB As Workbook
Dim beforeB As Workbook
Dim x As Variant
Dim bFnm As String '現ファイル名
Dim bFnm1 As String '現機種名
Dim bFnm2 As String '前機種上位品番
Dim bFnm3 As String '行き先機種上位品番
Dim bFnm4 As String '前機種投入工程
Dim bFnm5 As String '行き先機種投入工程
Dim fNmTx As String
Dim dAtaBk As Variant
Dim t As Double
t = Timer
Set zTb = Workbooks(zProgramID)
With zTb.Worksheets("機種間共通部品検索")
v = .Range("D1:YA154").Value
End With
For i = 2 To UBound(v, 2) Step 13
bFnm = v(3, i - 1) '現ファイル名
bFnm1 = v(8, i - 1) '現機種名
= v(5, i - 1) '前機種上位品番
bnFm3 = v(7, i - 1) '行き先機種上位品番
bnFm4 = v(5, i + 1) '前機種投入工程
bnFm5 = v(7, i + 1) '行き先機種投入工程
For j = 11 To UBound(v, 1)
If v(j, i) <> "" Then
ReDim tMp(1 To 5)
tMp(1) = bFnm '現ファイル名
tMp(2) = v(j, i) '前機種ファイル名
tMp(3) = v(j, i + 1) '前機種と次機種共通部品 棚番
tMp(4) = v(j, i - 1) '行き先機種名
tMp(5) = bFnm1 '現機種名
ReDim Preserve iDx(n)
iDx(n) = tMp
n = n + 1
End If
Next
Next
For i = LBound(iDx) To UBound(iDx)
'前機種名
If iDx(i)(1) <> "" Then
fNmTx = ThisWorkbook.Path & "\出庫リスト\" & iDx(i)(1) & ".xlsx"
If zWbExists(fNmTx) Then
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Dim srcWS As Workbook
Dim dstWS As Worksheet
Set dstWS = ThisWorkbook.Worksheets("機種間共通部品検索")
Set srcWS = Workbooks.Open(fNmTx)
With srcWS.Worksheets(1)
srcWS.Worksheets(1).Range("B6:AJ359"). _
AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:=dstWS.Range("D4:E5"), _
Unique:=True
x = Application.Match(iDx(i)(3), srcWS.Worksheets(1).Range("B:B"), 0)
If Not IsError(x) Then
If srcWS.Worksheets(1).Cells(x, "H") = "" Then srcWS.Worksheets(1).Cells(x, "H") = tMp(4)
srcWS.Worksheets(1).Cells(x, "H").EntireColumn.AutoFit
dAtaBk = srcWS.Worksheets(1).Cells(x, "E").Value
End If
End With
srcWS.Close True
Set srcWS = Nothing
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Else
MsgBox "前機種F Non" & Chr(13) & iDx(i)(1) & ".xlsx"
Exit For
End If
End If
'行き先機種名
fNmTx = ThisWorkbook.Path & "\出庫リスト\" & iDx(i)(2) & ".xlsx"
If zWbExists(fNmTx) Then
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Dim dstWS1 As Worksheet
Set dstWS1 = ThisWorkbook.Worksheets("機種間共通部品検索")
Dim srcWS1 As Workbook
Set srcWS1 = Workbooks.Open(fNmTx)
With srcWS1.Worksheets(1)
Dim c As Range
With srcWS1.Worksheets(1)
srcWS1.Worksheets(1).Range("B6:AJ359"). _
AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:=dstWS1.Range("D6:E7"), _
Unique:=True
For Each c In .AutoFilter.Range.SpecialCells(xlCellTypeVisible)
Next c
x = Application.Match(iDx(i)(3), srcWS1.Worksheets(1).Range("B:B"), 0)
If Not IsError(x) Then
If srcWS1.Worksheets(1).Cells(x, "A") = "" Then srcWS1.Worksheets(1).Cells(x, "A") = tMp(5)
srcWS1.Worksheets(1).Cells(x, "A").EntireColumn.AutoFit
If srcWS1.Worksheets(1).Cells(x, "C") = "" Then srcWS1.Worksheets(1).Cells(x, "C") = dAtaBk
dAtaBk = ""
End If
End With
End With
srcWS1.Close True
Set srcW1 = Nothing
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Else
MsgBox "行き先機種F Non" & Chr(13) & iDx(i)(2) & ".xlsx"
Exit For
End If
If i Mod 30 = 0 Then DoEvents
Next
Set zTb = Nothing
Erase v, iDx, tMp
End Sub
Private Function zWbExists(ByVal fp As String) As Boolean
zWbExists = False
If Dir(fp) <> "" Then zWbExists = True
End Function
補足
AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:=dstWS.Range("D4:E5"), _
AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:=dstWS1.Range("D6:E7"), _
のdstWS.Range("D4:E5")とdstWS1.Range("D6:E7")は
dstWS.Range("bFnm2",bFnm4")
dstWS.Range("bFnm3",bFnm5") が入ると予測されます。
（u） 2021/04/06(火) 12:33
＞＞前回ご教授いただいたコードは前と行き先のファイル名は違う場合は有効で、 ＞＞今悩んでいるのが開くファイルが前と行き先で同一の場合どうするかということです。 ↑
と棚番が重複とは、別問題だとおもうのですが。 やはり、よくわかりません。
棚番、 ｊ列、 Ｋ列 A705 ZY-33260000 マウント（表） A705 ZY-33260000 マウント（表）
のように全く同じになることはないのでしょうか。
（隠居じーさん） 2021/04/06(火) 12:49
（隠居じーさん） 2021/04/06(火) 14:05
■１
↓すごい違和感があります。
Dim srcWS As Workbook Set srcWS = Workbooks.Open(fNmTx)
WSって普通に考えるとWowksheetの略だとおもうんですが、Workbookの変数名に使っちゃったら混乱しませんか？
■２
ユーザー定義関数の「zWbExists」は理解できてるんですか？
個人的には、別建てにすることでかえって複雑になってるような気がします。
■３
真面目にインデントを付けてみてはどうですか？
部分的に取り出してインデントを付けて若干整理してみると↓のようになるわけですが
Dim c As Range
With srcWS1.Worksheets(1)
With srcWS1.Worksheets(1)
srcWS1.Worksheets(1).Range("B6:AJ359").AdvancedFilter _
Action:=xlFilterInPlace, CriteriaRange:=dstWS1.Range("D6:E7"), Unique:=True
For Each c In .AutoFilter.Range.SpecialCells(xlCellTypeVisible)
Next c
x = Application.Match(iDx(i)(3), srcWS1.Worksheets(1).Range("B:B"), 0)
If Not IsError(x) Then
If srcWS1.Worksheets(1).Cells(x, "A") = "" Then srcWS1.Worksheets(1).Cells(x, "A") = tMp(5)
srcWS1.Worksheets(1).Cells(x, "A").EntireColumn.AutoFit
If srcWS1.Worksheets(1).Cells(x, "C") = "" Then srcWS1.Worksheets(1).Cells(x, "C") = dAtaBk
dAtaBk = ""
End If
End With
End With
・意味のないループがある ・なぜか「With srcWS1.Worksheets(1)」が２段構えになっている（しかも意味のないループ部分以外では使ってない）
のようなツッコミ所が見受けられます。
（もこな２ ） 2021/04/06(火) 15:07
Unique:=True
行き先機種は
AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:=dstWS1.Range(""), _
となっています。
もこな2様
突っ込みどころあるのはご容赦ください。
隠居じーさん様のコードを今回追加したい部分を自分なりに書いた結果がこれになります。
すみません。エラーが出なかったのでOKかなと思ったのが本音です。
不要な部分が多いですね。誠にすみません。
質問の答えになっていないかもしれませんがご容赦願います
Unique:=True
（u） 2021/04/06(火) 15:22
＞＞J列の上位品番は機種間共通検索シートのD6、K列の投入工程は機種間共 ＞＞通検索シートのE5を基準にしています。~~~ ＞＞ 行き先機種は ＞＞J列の上位品番は機種間共通検索シートのD7、K列の投入工程は機種間共通検索シートのE7を基準にしてます 両方とも、5行目、7行目の、間違いでは。。。ご確認を。m(__)m
もこな2さん、ありがとうございます。 ＾＾
再度、確認してみます。他にもいろいろありそぉな。。。＾＾；
もうすこし、考えてみます。
m(__)m
（隠居じーさん） 2021/04/06(火) 15:40
こんばんは ＾＾ 了解です。只今、勘案中。。。まとまりましたら また、ご連絡いたします。。。半分、忘れかけてて。。。 思い出すのに、お時間がかかるかも。。。(￣▽￣；) でわ。。。m(__)m （隠居じーさん） 2021/04/06(火) 17:15
（隠居じーさん） 2021/04/06(火) 20:35
前機種、行き先機種上位品番ですが、空白の場合もあります。
投入工程は必ず入ります。
空白の場合は投入工程でフィルタを掛け
上位品番、投入工程両方入っている場合は
上位品番でフィルタを掛け次に投入工程でフィルタを掛けます。
（u） 2021/04/06(火) 21:28
あ。。。はい。。。ｗ 自信がなくなってきました。。。＾＾；。。。。 お仕事の内容が、畑違いもあり、全くわからないので、断言は出来ませんが 棚番って、如何なる場合でも、一意に設計するべきだと、思っていたのですが。 システム全体が脆弱なような気がしてきました。なんともなければ、幸いですが 。。。私の勘違いでしたらお許しを。 余談はこれくらいにして、その、列も、一列づつ、ふえているよ〜ですし、実験 データーも作り直さないと、いけないようなきがいたしますので。 あまり、期待せずに、気長にお待ちください。 同時に、他の回答者様のアドバイスもお待ちくださいね。 でわでわ。。。m(__)m （隠居じーさん） 2021/04/06(火) 23:33
＞＞ちなみに、マクロの記録でやった際のコードは
Range("A6:AN154").AdvancedFilter Action:=xlFilterInPlace, Unique:=False
＞＞でした。
＞＞ （u） 2021/04/05(月) 22:09
と
（u） 2021/04/06(火) 07:32
で
ご提示の表と範囲の開始行、並びに
範囲その物が相違します。
どちらが、本当なのでしょう。＾＾；
m(_ _)m
（隠居じーさん） 2021/04/07(水) 19:53
全体は Range("A6:AN359")が正解でよろしいですか。
（隠居じーさん） 2021/04/07(水) 20:36
この質問者あれこれ希望書いているだけで、自分で考える事はしないのかね。 回答者は良く付き合ってられますね。 （pl） 2021/04/07(水) 20:57
おはようございます ＾＾ フイルターは使っていませんが、同じ効果はあるはずです。 なにせ、回し好きなもので。。。＾＾； 範囲とかエトセトラ、そちらの環境に合わせて下さいね。 とりあえずこんな方法でもできるかなぁ？。。。みたいな 程度で、何かの参考の足しにでも。。。← ならないかも。。。(￣▽￣；) 出来たら、横並びは、御止めになって、一件、一行で縦方向 に入力して、テーブルにしておくと、後々すごぉ〜く、楽な のではと、私は思います。 余計なお世話でしたらお許しを。。。m(__)m という事で。わたしは、ここまで。とさせて戴きます。m(__)m
Option Explicit
Sub OneInstanceMain03()
Const zProgramID As String = "機種間共通部品Z軸検索Filter編.xlsm"
Dim zTb As Workbook
Dim i As Long
Dim j As Long
Dim k As Long
Dim n As Long
Dim v() As Variant
Dim tMp() As Variant
Dim iDx() As Variant
Dim leadB As Workbook
Dim beforeB As Workbook
Dim x As Variant
Dim fNmTx As String
Dim fNmBk As String
Dim dAtaBk As Variant
Dim rr As Range
Dim t As Double
t = Timer
Set zTb = Workbooks(zProgramID)
With zTb.Worksheets("機種間共通検索")
v = .Range("D1:YC154").Value
End With
For i = 2 To UBound(v, 2) Step 13
For j = 12 To UBound(v, 1)
If v(j, i) <> "" Then
ReDim tMp(1 To 3 + 2)
tMp(1) = v(3, i - 1)
tMp(2) = v(j, i)
tMp(3) = v(j, i + 1)
tMp(4) = v(7, i - 1) '先行機種 上位品番
tMp(5) = v(7, i) '先行機種 投入工程
ReDim Preserve iDx(n)
iDx(n) = tMp
n = n + 1
End If
Next
Next
n = 0
For i = LBound(iDx) To UBound(iDx)
fNmTx = ThisWorkbook.Path & "\" & iDx(i)(2) & ".xlsx"
If zWbExists(fNmTx) Then
Set leadB = Workbooks.Open(fNmTx)
With leadB.Worksheets(1)
Set rr = .Range("B6:AJ359")
For k = 2 To rr.Rows.Count
If iDx(i)(4) = "" Then
If rr(k, 1) = iDx(i)(3) And rr(k, 35) = iDx(i)(5) Then
n = rr(k, 1).Row
End If
Else
If rr(k, 1) = iDx(i)(3) And rr(k, 35) = iDx(i)(5) And rr(k, 30) = iDx(i)(4) Then
n = rr(k, 1).Row
End If
End If
Next
If n > 0 Then
If iDx(i)(1) <> "" Then .Cells(n, "A") = iDx(i)(1)
fNmBk = iDx(i)(2)
dAtaBk = .Cells(n, "F").Value
End If
n = 0
End With
leadB.Close True
Set rr = Nothing
Set leadB = Nothing
Else
MsgBox "行き先機種F Non" & Chr(13) & iDx(i)(2) & ".xlsx"
Exit For
End If
'前機種名
If iDx(i)(1) <> "" Then
fNmTx = ThisWorkbook.Path & "\" & iDx(i)(1) & ".xlsx"
If zWbExists(fNmTx) Then
Set beforeB = Workbooks.Open(fNmTx)
With beforeB.Worksheets(1)
x = Application.Match(iDx(i)(3), .Range("B:B"), 0)
If Not IsError(x) Then
If fNmBk <> "" Then
.Cells(x, "H") = fNmBk
fNmBk = ""
End If
If dAtaBk <> "" Then
.Cells(x, "C") = dAtaBk
dAtaBk = ""
End If
End If
End With
beforeB.Close True
Set beforeB = Nothing
Else
MsgBox "前機種F Non" & Chr(13) & iDx(i)(1) & ".xlsx"
Exit For
End If
End If
If i Mod 30 = 0 Then DoEvents
Next
Set zTb = Nothing
Erase v, iDx, tMp
MsgBox "終了 " & Format(Int(Timer - t) / 24 / 60 / 60, "hh : mm : ss") & _
Format((Timer - t) - Int(Timer - t), ".000") & " 秒"
End Sub
Private Function zWbExists(ByVal fp As String) As Boolean
zWbExists = False
If Dir(fp) <> "" Then zWbExists = True
End Function
（隠居じーさん） 2021/04/08(木) 08:59
fNmTx = ThisWorkbook.Path & "\" & iDx(i)(2) & ".xlsx"
If zWbExists(fNmTx) Then
Set leadB = Workbooks.Open(fNmTx)
With leadB.Worksheets(1)
Set rr = .Range("B6:AJ359")
For k = 2 To rr.Rows.Count
If iDx(i)(4) = "" Then
If rr(k, 1) = iDx(i)(3) And rr(k, 35) = iDx(i)(5) Then
n = rr(k, 1).Row
End If
Else
If rr(k, 1) = iDx(i)(3) And rr(k, 35) = iDx(i)(5) And rr(k, 30) = iDx(i)(4) Then
n = rr(k, 1).Row
End If
End If
Next
If n > 0 Then
If iDx(i)(1) <> "" Then .Cells(n, "A") = iDx(i)(1)
fNmBk = iDx(i)(2)
dAtaBk = .Cells(n, "F").Value
End If
n = 0
End With
leadB.Close True
Set rr = Nothing
Set leadB = Nothing
Else
MsgBox "行き先機種F Non" & Chr(13) & iDx(i)(2) & ".xlsx"
Exit For
End If
Private Function zWbExists(ByVal fp As String) As Boolean
zWbExists = False
If Dir(fp) <> "" Then zWbExists = True
End Function
ご教授願います。
（u） 2021/04/14(水) 17:49
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 65535
.TintAndShade = 0
.PatternTintAndShade = 0
End With
これをどこにいれるべきかわかりません。
ご教授願います。
（u） 2021/04/14(水) 21:13
ちなみに↓の1行で同じことになるでしょう。
Selection.Interior.Color = 65535
（もこな２） 2021/04/14(水) 21:17
（もこな２） 2021/04/14(水) 21:20
いや、まさにその部分ですよ。
ブック名は「iDx(i)(1)」なわけですよね。
なら、それが書いてあったのはどの【セル】なのか特定して、その【セル】を操作しないとダメですよね？
（もこな２） 2021/04/14(水) 22:05
Set U = iDx(i)(2)
U.Interior.Color = 65535
としましたが、U.Interior.Color = 65535のUで型が一致しませんとでます。
iDx(i)(2)でファイル名が表示されているセルは取得しています。
どうすればよいでしょうか？
（u） 2021/04/14(水) 22:28
ちなみに、取得したと思っているセル番地はどこですか？
（なぜ、取得したとおもわれたのか確認のために聞いてます）
（もこな２） 2021/04/15(木) 04:22
Const zProgramID As String = "機種間共通部品,Z軸検索改良版??6(YDS)TRAY無し.xlsm"
Dim zTb As Workbook
Dim i As Long
Dim j As Long
Dim k As Long
Dim n As Long
Dim v() As Variant
Dim tMp() As Variant
Dim iDx() As Variant
Dim leadB As Workbook
Dim leadB1 As Workbook
Dim beforeB As Workbook
Dim x As Variant
Dim fNmTx As String
Dim fNmBk As String
Dim dAtaBk As Variant
Dim rr As Range
Dim t As Double
t = Timer
Set zTb = Workbooks(zProgramID)
With zTb.Worksheets("機種間共通部品検索")
v = .Range("D1:ABW154").Value
End With
For i = 2 To UBound(v, 2) Step 15
For j = 11 To UBound(v, 1)
If v(j, i) <> "" Then
ReDim tMp(1 To 5 + 2)
tMp(1) = v(3, i + 1) '現ファイル名
tMp(2) = v(j, i + 2) '行き先ファイル名
tMp(3) = v(j, i + 3) '棚番
tMp(4) = v(j, i - 1) '行き先機種 上位品番
tMp(5) = v(j, i) '行き先機種 投入工程
tMp(6) = v(4, i + 1) '現機種名
tMp(7) = v(j, i + 1) '行き先機種名
ReDim Preserve iDx(n)
iDx(n) = tMp
n = n + 1
End If
Next
Next
For i = LBound(iDx) To UBound(iDx)
'前機種名
If iDx(i)(1) <> "" Then
fNmTx = ThisWorkbook.Path & "\出庫リスト\" & iDx(i)(1) & ".xlsx"
If zWbExists(fNmTx) Then
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Set beforeB = Workbooks.Open(fNmTx)
With beforeB.Worksheets(1)
Set rr = .Range("B6:AJ359")
x = Application.Match(iDx(i)(3), .Range("B:B"), 0)
If Not IsError(x) Then
If .Cells(x, "H") = "" Then .Cells(x, "H") = iDx(i)(7) '空白なら書き込む 文字があったら何もしない
.Cells(x, "H").EntireColumn.AutoFit
dAtaBk = .Cells(x, "E").Value
End If
End With
beforeB.Close True
Set beforeB = Nothing
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Else
MsgBox "前機種F Non" & Chr(13) & iDx(i)(1) & ".xlsx"
Exit For
End If
End If
'行き先機種名
fNmTx = ThisWorkbook.Path & "\出庫リスト\" & iDx(i)(2) & ".xlsx"
If zWbExists(fNmTx) Then
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Set leadB = Workbooks.Open(fNmTx)
With leadB.Worksheets(1)
x = Application.Match(iDx(i)(3), .Range("B:B"), 0)
If Not IsError(x) Then
If iDx(i)(1) <> "" Then .Cells(x, "A") = iDx(i)(6)
.Cells(x, "A").EntireColumn.AutoFit
If .Cells(x, "C") = "" Then .Cells(x, "C") = dAtaBk
dAtaBk = ""
End If
End With
leadB.Close True
Set leadB = iDx(i)(2)
leadB.Interior.Color = 65535
Set lead = Nothing
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Else
MsgBox "行き先機種F Non" & Chr(13) & iDx(i)(2) & ".xlsx"
Exit For
End If
If i Mod 30 = 0 Then DoEvents
Next
Set zTb = Nothing
Erase v, iDx, tMp
MsgBox "終了 " & Format(Int(Timer - t) / 24 / 60 / 60, "hh : mm : ss") & _
Format((Timer - t) - Int(Timer - t), ".000") & " 秒"
End Sub
Private Function zWbExists(ByVal fp As String) As Boolean
zWbExists = False
If Dir(fp) <> "" Then zWbExists = True
End Function
セル番地はtMp(2) = v(j, i + 2) です。 デバックでiDx(i)(2)にカーソルを当ててファイル名が表示されているのを確認しました。 （u） 2021/04/15(木) 06:06
回答例：○○シートのB12セル
■５
要は↓のようにしているのですから
セル範囲 → 配列
↓のように、もう一度セル範囲に戻して「iDx(i)(2)」に相当するセルを考えないとダメですよってことです。配列の中身を聞いているんじゃありません。
セル範囲 → 配列 → セル範囲
あと、どうでもいいですが【デバッグ】とは、プログラム修正作業のことです。エラーが発生する状況のことではありません。
（もこな２） 2021/04/15(木) 07:35
Worksheets("機種間共通部品検索").Range("G12").Interior.Color = 65535
ちなみにどうやって特定したのですか？目視で確認したとかは無しですよ。
「 v(j, i + 2) 」なり「iDx(i)(2)」から戻す方法が分からないとExcel君に指示できないですよね？
（もこな２） 2021/04/15(木) 07:54
（u） 2021/04/15(木) 07:57
（もこな２ ） 2021/04/15(木) 08:49
v = .Range("D1:ABW154").Value
して、
tMp(2) = v(j, i + 2) '行き先ファイル名
で
iDx(n) = tMp
なので、iDx(i)(2) は、行き先ファイル名が、文字列の値として入ってる
ステップ実行したとき、iDx(i)(2)の値を調べたとして、
ファイル名は分かっても、その値が入っていたセルがどこなのか分かる訳ないでしょ
ということ。
iDx(i)(2)の値（ファイル名）見て→ G12 です ってどうやって回答したんですか？？
（とおりすがり） 2021/04/15(木) 11:13
For i = 2 To UBound(v, 2) Step 15
For j = 11 To UBound(v, 1)
If v(j, i) <> "" Then
ReDim tMp(1 To 5 + 2)
tMp(1) = v(3, i + 1) '現ファイル名
tMp(2) = v(j, i + 2) '行き先ファイル名
tMp(3) = v(j, i + 3) '棚番
tMp(4) = v(j, i - 1) '行き先機種 上位品番
tMp(5) = v(j, i) '行き先機種 投入工程
tMp(6) = v(4, i + 1) '現機種名
tMp(7) = v(j, i + 1) '行き先機種名
ReDim Preserve iDx(n)
iDx(n) = tMp '←★★★ ここに注目 ★★★
n = n + 1
End If
Next
で、「v」という配列の正体は↓ですよね
v = Workbooks("機種間共通部品,Z軸検索改良版??6(YDS)TRAY無し.xlsm").Worksheets("機種間共通検索").Range("D1:ABW154").Value
なので、
iDx(i)(2) の正体は tMp(2)(n) ということになり
tMp(2)(n) の正体は v(j, i + 2)(n)ということですから、目的のセルは
【機種間共通部品,Z軸検索改良版??6(YDS)TRAY無し.xlsm"】というブックの 【機種間共通部品検索】というシートの 【D1:ABW154】のどこか
なんだろうなとはおもいますけど、「tMp(2)(n)」からどうやって求めましょう？というお話です。
ちなみに「iDx(i)(2) 」ではなく、「 v(j, i + 2)」から求めるのであればぐっと簡単になりますね。
↓のようなことになるわけですから。
zTb.Worksheets("機種間共通部品検索").Range("D1:ABW154").Cells(j, i + 2)
■８
余談ですが、配列にしたことでかえってごちゃごちゃしてるような気がするので、初めから配列にせずRangeオブジェクトとして扱ったほうがよかったんじゃないかなぁなんて思います。
（好みの問題でしょうが）
（もこな２ ） 2021/04/15(木) 12:25
こんにちは ＾＾...解決案。。。極簡単バージョン！(#^.^#) レンジ変数r追加で、vと同じ範囲をほり込んどいて。 tMpを拡張して、行列情報をidxで対比表に追加して idx作成時、色付きは排除して、 書込み時に、r(j,i）で同期取れてますので、色なり なんなり、付けてやってください。 r(iDx(i)(6), iDx(i)(7)).Interior.Color = vbYellow みたいな感じになるかと。。。添え字は現在の設定により 変化致します。[あたりまえですが＾＾；]。。。m(__)m
（隠居じーさん） 2021/04/15(木) 14:17
（u） 2021/04/15(木) 17:21
いえ
Set
が
いります
.value
は
いりません
Dim r As Range
With zTb.Worksheets("機種間共通検索")
Set r = .Range("D1:YC154")
v = r.Value
End With
みたいに、します。
これで、ｖ、ｒ
は同じ行、列、に対応する、要素数、番号等で、[jとかi]
同じ値が参照できます。
（隠居じーさん） 2021/04/15(木) 19:09
Const zProgramID As String = "機種間共通部品,Z軸検索改良版??6(YDS)TRAY無し.xlsm"
Dim zTb As Workbook
Dim i As Long
Dim j As Long
Dim k As Long
Dim n As Long
Dim v() As Variant
Dim r As Range
Dim tMp() As Variant
Dim iDx() As Variant
Dim leadB As Workbook
Dim beforeB As Workbook
Dim x As Variant
Dim fNmTx As String
Dim fNmBk As String
Dim dAtaBk As Variant
Dim rr As Range
Dim t As Double
t = Timer
Set zTb = Workbooks(zProgramID)
With zTb.Worksheets("機種間共通部品検索")
v = .Range("D1:ABW154").Value
End With
With zTb.Worksheets("機種間共通部品検索")
Set r = .Range("D1:ABW154")
v = r.Value
End With
For i = 2 To UBound(v, 2) Step 15
For j = 11 To UBound(v, 1)
If v(j, i) <> "" Then
ReDim tMp(1 To 6 + 2)
tMp(1) = v(3, i + 1) '現ファイル名
tMp(2) = v(j, i + 2) '行き先ファイル名
tMp(3) = v(j, i + 3) '棚番
tMp(4) = v(j, i - 1) '行き先機種 上位品番
tMp(5) = v(j, i) '行き先機種 投入工程
tMp(6) = v(4, i + 1) '現機種名
tMp(7) = v(j, i + 1) '行き先機種名
tMp(8) = r(j, i + 2) '行き先ファイル名
ReDim Preserve iDx(n)
iDx(n) = tMp
n = n + 1
End If
Next
Next
For i = LBound(iDx) To UBound(iDx)
'前機種名
If iDx(i)(1) <> "" Then
fNmTx = ThisWorkbook.Path & "\出庫リスト\" & iDx(i)(1) & ".xlsx"
If zWbExists(fNmTx) Then
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Set beforeB = Workbooks.Open(fNmTx)
With beforeB.Worksheets(1)
Set rr = .Range("B6:AJ359")
x = Application.Match(iDx(i)(3), .Range("B:B"), 0)
If Not IsError(x) Then
If .Cells(x, "H") = "" Then .Cells(x, "H") = iDx(i)(7) '空白なら書き込む 文字があったら何もしない
.Cells(x, "H").EntireColumn.AutoFit
dAtaBk = .Cells(x, "E").Value
End If
End With
beforeB.Close True
Set beforeB = Nothing
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Else
MsgBox "前機種F Non" & Chr(13) & iDx(i)(1) & ".xlsx"
Exit For
End If
End If
'行き先機種名
fNmTx = ThisWorkbook.Path & "\出庫リスト\" & iDx(i)(2) & ".xlsx"
If zWbExists(fNmTx) Then
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Set leadB = Workbooks.Open(fNmTx)
With leadB.Worksheets(1)
x = Application.Match(iDx(i)(3), .Range("B:B"), 0)
If Not IsError(x) Then
If iDx(i)(1) <> "" Then .Cells(x, "A") = iDx(i)(6)
.Cells(x, "A").EntireColumn.AutoFit
If .Cells(x, "C") = "" Then .Cells(x, "C") = dAtaBk
dAtaBk = ""
End If
End With
leadB.Close True
r(iDx(i)(2), iDx(i)(8)).Interior.Color = vbYellow
Set lead = Nothing
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Else
MsgBox "行き先機種F Non" & Chr(13) & iDx(i)(2) & ".xlsx"
Exit For
End If
If i Mod 30 = 0 Then DoEvents
Next
Set zTb = Nothing
Erase v, iDx, tMp
MsgBox "終了 " & Format(Int(Timer - t) / 24 / 60 / 60, "hh : mm : ss") & _
Format((Timer - t) - Int(Timer - t), ".000") & " 秒"
End Sub
Private Function zWbExists(ByVal fp As String) As Boolean
zWbExists = False
If Dir(fp) <> "" Then zWbExists = True
End Function
現状はこのコードで実行すると
r(iDx(i)(2), iDx(i)(8)).Interior.Color = vbYellow
で型が一致しませんと出ます。
色を付けたいのはファイルを開き、書き込んで閉じたら色を付けたいです。
入れる場所はあっていますでしょうか？
（u） 2021/04/15(木) 19:57
こんばんは ＾＾
なにか。。。勘違いをされているようなのですが。。。
一部、範囲、及び、iDx配列への格納項目等、変更されていましたので。
コメントは、差し引けておりました。
当方のテスト環境のままで、恐縮ですが、同じようにそちらでご必要なように、
変更してください、ただ、色付けと2回目上書き防止は出来ていると思いますので
参考程度にして下さい。一度も処理されない場合対応処理も追加しています。
Option Explicit
Sub OneInstanceMain05()
Const zProgramID As String = "機種間共通部品Z軸検索Filter編改01.xlsm"
Dim zTb As Workbook
Dim i As Long
Dim j As Long
Dim k As Long
Dim n As Long
Dim v() As Variant
Dim tMp() As Variant
Dim iDx() As Variant
Dim leadB As Workbook
Dim beforeB As Workbook
Dim x As Variant
Dim fnmtx As String
Dim fNmBk As String
Dim dAtaBk As Variant
Dim rr As Range
Dim r As Range
Dim flgcnt As Long
Dim t As Double
t = Timer
Set zTb = Workbooks(zProgramID)
With zTb.Worksheets("機種間共通検索")
Set r = .Range("D1:YC154")
v = r.Value
End With
For i = 2 To UBound(v, 2) Step 13
For j = 12 To UBound(v, 1)
If v(j, i) <> "" And r(j, i).DisplayFormat.Interior.Color = 16777215 Then
ReDim tMp(1 To 7)
flgcnt = flgcnt + 1
tMp(1) = v(3, i - 1)
tMp(2) = v(j, i)
tMp(3) = v(j, i + 1)
tMp(4) = v(7, i - 1) '先行機種 上位品番
tMp(5) = v(7, i) '先行機種 投入工程
tMp(6) = j
tMp(7) = i
ReDim Preserve iDx(n)
iDx(n) = tMp
n = n + 1
End If
Next
Next
If flgcnt = 0 Then
Erase v, iDx
Set r = Nothing
Set zTb = Nothing
MsgBox "全て処理済みです"
Exit Sub
End If
n = 0
For i = LBound(iDx) To UBound(iDx)
fnmtx = ThisWorkbook.Path & "\" & iDx(i)(2) & ".xlsx"
If zWbExists(fnmtx) Then
Set leadB = Workbooks.Open(fnmtx)
r(iDx(i)(6), iDx(i)(7)).Interior.Color = vbYellow
With leadB.Worksheets(1)
Set rr = .Range("B6:AJ359")
For k = 2 To rr.Rows.Count
If iDx(i)(4) = "" Then
If rr(k, 1) = iDx(i)(3) And rr(k, 35) = iDx(i)(5) Then
n = rr(k, 1).Row
End If
Else
If rr(k, 1) = iDx(i)(3) And rr(k, 35) = iDx(i)(5) And rr(k, 30) = iDx(i)(4) Then
n = rr(k, 1).Row
End If
End If
Next
If n > 0 Then
If iDx(i)(1) <> "" Then .Cells(n, "A") = iDx(i)(1)
fNmBk = iDx(i)(2)
dAtaBk = .Cells(n, "F").Value
End If
n = 0
End With
leadB.Close True
Set rr = Nothing
Set leadB = Nothing
Else
MsgBox "行き先機種F Non" & Chr(13) & iDx(i)(2) & ".xlsx"
Exit For
End If
'前機種名
If iDx(i)(1) <> "" Then
fnmtx = ThisWorkbook.Path & "\" & iDx(i)(1) & ".xlsx"
If zWbExists(fnmtx) Then
Set beforeB = Workbooks.Open(fnmtx)
With beforeB.Worksheets(1)
x = Application.Match(iDx(i)(3), .Range("B:B"), 0)
If Not IsError(x) Then
If fNmBk <> "" Then
.Cells(x, "H") = fNmBk
fNmBk = ""
End If
If dAtaBk <> "" Then
.Cells(x, "C") = dAtaBk
dAtaBk = ""
End If
End If
End With
beforeB.Close True
Set beforeB = Nothing
Else
MsgBox "前機種F Non" & Chr(13) & iDx(i)(1) & ".xlsx"
Exit For
End If
End If
If i Mod 30 = 0 Then DoEvents
Next
Set zTb = Nothing
Set r = Nothing
Erase v, iDx, tMp
MsgBox "終了 " & Format(Int(Timer - t) / 24 / 60 / 60, "hh : mm : ss") & _
Format((Timer - t) - Int(Timer - t), ".000") & " 秒"
End Sub
Private Function zWbExists(ByVal fp As String) As Boolean
zWbExists = False
If Dir(fp) <> "" Then zWbExists = True
End Function
（隠居じーさん） 2021/04/15(木) 20:53
では失礼します。
（u） 2021/04/15(木) 22:11
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.