fork download
  1. Option Explicit
  2.  
  3. Public Sub 新比較()
  4. Dim ssh As Worksheet
  5. Dim msh As Worksheet
  6. Dim sbsh As Worksheet
  7. Dim wrow As Long
  8. Dim wcol As Long
  9. Dim wcols As String
  10. Dim trow As Long
  11. Dim tcol As Long
  12. Dim tcols As String
  13. Dim maxrow_s, maxrow_m, maxcol_m, maxrow_t, maxcol_t As Long
  14. Dim dicT1 As Object '項目管理(シート1)
  15. Dim dicT2 As Object '項目管理(シート2)
  16. Dim dicTw As Object '項目管理
  17. Dim dicN1 As Object '項目管理(シート1)
  18. Dim dicN2 As Object '項目管理(シート2)
  19. Dim dicR As Object '追加2020/3/14
  20. Dim ser_m As String 'ユニークキー列(シート1)
  21. Dim ser_t As String 'ユニークキー列(シート2)
  22. Dim Key As Variant
  23. Dim item As Variant
  24. Dim RC As Variant
  25. Dim SetFile As Variant
  26. Dim newSh As Worksheet
  27. Dim mwb As Workbook
  28. Dim twb As Workbook
  29. Dim tsh As Worksheet
  30. Dim maxrow_s2 As Long '追加 回答者
  31. Dim rng As Range '追加 回答者
  32. Set ssh = Worksheets("設定")
  33. Set dicT1 = CreateObject("Scripting.Dictionary") ' 連想配列の定義
  34. Set dicT2 = CreateObject("Scripting.Dictionary") ' 連想配列の定義
  35. Set dicTw = CreateObject("Scripting.Dictionary") ' 連想配列の定義
  36. Set dicN1 = CreateObject("Scripting.Dictionary") ' 連想配列の定義
  37. Set dicN2 = CreateObject("Scripting.Dictionary") ' 連想配列の定義
  38. Set dicR = CreateObject("Scripting.Dictionary") ' 連想配列の定義 追加2020/3/14
  39.  
  40.  
  41.  
  42.  
  43. '/////////////////////////////////コモンダイアログから転記先のシートを開く
  44.  
  45. RC = MsgBox("書き込むファイルを選択してください。", vbYesNo + vbQuestion, "確認")
  46.  
  47. If RC = vbNo Then Exit Sub
  48. SetFile = Application.GetOpenFilename("Microsoft Excelブック,*.xls?")
  49. If SetFile = "False" Then
  50. MsgBox "キャンセルしました"
  51. Exit Sub
  52. End If
  53.  
  54. Set mwb = Workbooks.Open(SetFile)
  55. Set msh = mwb.Worksheets("管理表")
  56.  
  57. Worksheets.Add After:=msh
  58. Set newSh = ActiveSheet
  59. newSh.Name = "差分"
  60.  
  61. Set sbsh = Worksheets("差分")
  62.  
  63. '/////////////////////////////////後で書き換えます◎
  64.  
  65. Sheets("管理表").Select
  66. Rows("1:4").Select
  67. Selection.Copy
  68. Sheets("差分").Select
  69. Rows("1:1").Select
  70. ActiveSheet.Paste
  71.  
  72. Application.DisplayAlerts = True
  73. Application.CutCopyMode = True
  74.  
  75.  
  76. '/////////////////////////////////最大行の取得し、設定シートに記載した列を取得
  77.  
  78. maxrow_s = ssh.Cells(Rows.Count, "G").End(xlUp).Row 'A列の最大行取得
  79. maxrow_s2 = ssh.Cells(Rows.Count, "L").End(xlUp).Row '追加回答者 L列の最大行取得
  80. Set rng = ssh.Range("L2:L" & maxrow_s2) '追加回答者
  81. '設定シート列取得
  82. For wrow = 3 To maxrow_s
  83. dicT1(ssh.Cells(wrow, "G").Value) = ssh.Cells(wrow, "H").Value
  84. dicT2(ssh.Cells(wrow, "G").Value) = ssh.Cells(wrow, "I").Value
  85. '2020/3/14追加開始
  86. If ssh.Cells(wrow, "A").Value <> "ユニークキー" Then
  87. dicR(ssh.Cells(wrow, "B").Value) = ssh.Cells(wrow, "C").Value
  88. End If
  89. '2020/3/14追加終了
  90. Next
  91.  
  92. If dicT1.Exists("ユニークキー") = False Then
  93. MsgBox ("設定シートに「ユニークキー」の項目なし")
  94. Exit Sub
  95. End If
  96.  
  97. ser_m = dicT1("ユニークキー")
  98. ser_t = dicT2("ユニークキー")
  99.  
  100. '各項目を記憶(シート1の列指定部分)
  101. maxcol_m = msh.Cells(4, Columns.Count).End(xlToLeft).Column '1行目の最終列を求める
  102. For wcol = 1 To maxcol_m
  103. dicTw(msh.Cells(4, wcol).Value) = wcol
  104. Next
  105.  
  106.  
  107. '項目存在チェック
  108. For Each item In dicT1
  109. If dicTw.Exists(item) = False Then
  110. MsgBox (item & "は管理表にありません")
  111. Exit Sub
  112. End If
  113. Next
  114.  
  115.  
  116. '項目の列位置チェック
  117. For Each item In dicT1
  118. wcols = dicT1(item)
  119. If msh.Cells(4, wcols).Value <> item Then
  120. msh.Cells(4, dicTw(item)).Interior.Color = vbYellow
  121. MsgBox ("処理中止しました")
  122. Exit Sub
  123. End If
  124. Next
  125.  
  126.  
  127. maxrow_m = msh.Cells(Rows.Count, ser_m).End(xlUp).Row 'sheet1 ユニークキー列の最大行取得
  128. 'ユニークキーの行を記憶
  129. For wrow = 4 To maxrow_m
  130. dicN1(msh.Cells(wrow, ser_m).Value) = wrow
  131. Next
  132. RC = MsgBox("参照するファイルを選択してください。", vbYesNo + vbQuestion, "確認")
  133. If RC = vbNo Then Exit Sub
  134. SetFile = Application.GetOpenFilename("Microsoft Excelブック,*.xls?")
  135. If SetFile = "False" Then
  136. MsgBox "キャンセルしました"
  137. Exit Sub
  138. End If
  139. Set twb = Workbooks.Open(SetFile)
  140. Set tsh = twb.Worksheets("管理表")
  141.  
  142.  
  143. '各項目を記憶
  144. maxcol_t = tsh.Cells(3, Columns.Count).End(xlToLeft).Column '1行目の最終列を求める
  145. dicTw.RemoveAll
  146. For wcol = 1 To maxcol_t
  147. dicTw(tsh.Cells(3, wcol).Value) = wcol
  148. Next
  149.  
  150.  
  151. '項目存在チェック
  152. For Each item In dicT2
  153. If dicTw.Exists(item) = False Then
  154. MsgBox (item & "は管理表にありません")
  155. Exit Sub
  156. End If
  157. Next
  158.  
  159.  
  160. '項目の列位置チェック
  161. For Each item In dicT2
  162. wcols = dicT2(item)
  163. If tsh.Cells(3, wcols).Value <> item Then
  164. MsgBox (item & "の列が異なります")
  165. Exit Sub
  166. End If
  167. Next
  168.  
  169.  
  170. maxrow_t = tsh.Cells(Rows.Count, ser_t).End(xlUp).Row 'sheet1 ユニークキー列の最大行取得
  171. 'ユニークキーの行を記憶
  172. For wrow = 3 To maxrow_t
  173. dicN2(tsh.Cells(wrow, ser_t).Value) = wrow
  174. Next
  175.  
  176.  
  177.  
  178. 'DE列をクリア
  179. msh.Range("DE2:DE" & maxrow_m).Value = ""
  180. msh.Range("DE2:DE" & maxrow_m).Interior.Pattern = xlNone
  181.  
  182.  
  183.  
  184. '/////////////////////////////////比較⇒処理
  185.  
  186. For wrow = 4 To maxrow_m
  187. Key = msh.Cells(wrow, ser_m).Value
  188.  
  189. 'If msh.Cells(wrow, "B").Value Like "*A*" _
  190. 'Or msh.Cells(wrow, "B").Value Like "*B*" Then
  191. If IfInstrs(msh.Cells(wrow, "B").Value, rng) = True Then '追加 回答者
  192. If msh.Cells(wrow, "G").Value = "設計OK" Or msh.Cells(wrow, "G").Value = "検討中" Then
  193. If dicN2.Exists(Key) = False Then
  194.  
  195.  
  196. 'シート1にありシート2にないユニークキーの処理
  197. msh.Cells(wrow, "DE").Value = "レコード削除"
  198. msh.Cells(wrow, "DE").Interior.Color = vbYellow
  199. Else
  200. trow = dicN2(Key)
  201. '2020/3/14修正開始
  202. For Each item In dicR
  203. wcols = item
  204. tcols = dicR(item)
  205.  
  206.  
  207. If msh.Cells(wrow, wcols).Value = "" _
  208. And tsh.Cells(trow, tcols).Value = "" Then
  209.  
  210. Else
  211. '転記処理'
  212. If msh.Cells(wrow, "B").Value Like "*A*" _
  213. Or msh.Cells(wrow, "B").Value Like "*B*" Then
  214. If msh.Cells(wrow, "G").Value = "設計OK" Or msh.Cells(wrow, "G").Value = "検討中" Then
  215. If msh.Cells(wrow, wcols).Value = "" Or msh.Cells(wrow, wcols).Value = "-" Then
  216.  
  217. msh.Cells(wrow, wcols).Value = tsh.Cells(trow, tcols).Value
  218. msh.Cells(wrow, "DE").Value = "転記あり"
  219. msh.Cells(wrow, wcols).Interior.Color = vbCyan
  220. msh.Cells(wrow, wcols).Interior.Color = vbCyan
  221.  
  222. Else
  223. '元データがあり差分がある場合、DE列に「変更あり」を記載し、黄色く色付け
  224. '差分ファイルに転記し色付け
  225. If msh.Cells(wrow, "B").Value Like "*A*" _
  226. Or msh.Cells(wrow, "B").Value Like "*B*" Then
  227. If msh.Cells(wrow, "G").Value = "設計OK" Or msh.Cells(wrow, "G").Value = "検討中" Then
  228. If msh.Cells(wrow, wcols).Value <> tsh.Cells(trow, tcols).Value Then
  229.  
  230. msh.Cells(wrow, "DF").Interior.Color = vbYellow
  231. msh.Cells(wrow, "DF") = "変更あり"
  232. msh.Cells(wrow, wcols).Interior.Color = vbYellow
  233. sbsh.Cells(wrow, wcols).Value = tsh.Cells(trow, tcols).Value
  234. sbsh.Cells(wrow, wcols).Interior.Color = vbYellow
  235.  
  236. End If
  237. End If
  238. End If
  239. End If
  240. End If
  241. End If
  242. End If
  243. Next
  244. '2020/3/14修正終了
  245. dicN2.Remove (Key)
  246. End If
  247. End If
  248. End If
  249. Next
  250.  
  251.  
  252. '/////////////////////////////////ユニークキーが追加されるようなことがある場合、ここをアクティブにする
  253.  
  254. 'シート2にありシート1にないユニークキーを追加する
  255. 'wrow = maxrow_m + 1
  256. 'For Each key In dicN2
  257. ' trow = dicN2(key)
  258. ' '2020/3/14修正開始
  259. ' msh.Cells(wrow, ser_m).Value = tsh.Cells(trow, ser_t).Value
  260. ' For Each item In dicR
  261. ' wcols = item
  262. ' tcols = dicR(item)
  263. ' msh.Cells(wrow, wcols).Value = tsh.Cells(trow, tcols).Value
  264. ' Next
  265. ' '2020/3/14修正終了
  266. ' wrow = wrow + 1
  267. 'Next
  268.  
  269.  
  270. '/////////////////////////////////ファイルを閉じて完了
  271.  
  272. Application.DisplayAlerts = False
  273. twb.Close False
  274. Application.DisplayAlerts = True
  275. MsgBox "完了しました"
  276. End Sub
  277.  
  278. Public Function IfInstrs(ByVal word As String, ByVal rng As Range) As Boolean
  279. Dim wrg As Range
  280. For Each wrg In rng
  281. If InStr(1, word, wrg.Value) > 0 Then
  282. IfInstrs = True
  283. Exit Function
  284. End If
  285. Next
  286. IfInstrs = False
  287. End Function
  288.  
  289.  
Not running #stdin #stdout 0s 0KB
stdin
Standard input is empty
stdout
Standard output is empty