[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『VBAで条件分岐』（わく）
VBA初心者で全く分からないため、お手数ですがコードを教えていただきたいです。
2つのCSVデータからデータを別ブックに転記したいのですが、 条件分岐が多数あります。
下記条件毎に、それぞれZ列〜AG列の8列に転記したいです。
■転記元シート1 A列 → 番号（1、10、250等の数字） ※重複無し B列 → 実行計画、手配計画の2種類 C列 → 計画、見込の2種類 F列 → 義務No※重複有 G列 → 却下、承認済の2種類 AR列 → 日付
転記元のデータは下の4つの条件の組み合わせになっているのですが、
1.B列が"実行計画"・C列が"計画"
2.B列が"手配計画"・C列が"計画"
3.B列が"実行計画"・C列が"見込"
4.B列が"手配計画"・C列が"見込"
※F列の義務Noが複数あった場合、A列の番号が一番大きいものを最新として 転記していきたいです。
【転記元の条件】 【転記先】
1. → Z列にG列の情報、AA列にAR列の情報を転記
2.→ AB列にG列の情報、AC列にAR列の情報を転記
3.→ 何もしない
4.→ AD列にG列の情報、AE列にAR列の情報を転記
■転記元シート2
A列 → 番号（1、10、250等の数字)※重複無し
E列 → 義務No※重複有
F列 → 却下、承認済
AR列 → 日付
転記元シート1と同じように、E列の義務Noが複数あった場合、A列の番号が一番大きいものを最新として転記したいです。
【転記先】 AF列にF列の情報、AG列にAR列の情報を転記
複雑で申し訳ございませんが、コードをご教授のほどよろしくお願いいたします。
＜ 使用 Excel：Office365、使用 OS：Windows10 ＞
（γ） 2021/09/15(水) 12:14
Sub Draft1()
Dim Sh1 As Worksheet
Dim Sh2 As Worksheet
Dim Sh3 As Worksheet
Dim SearchRange As Range
Dim iRange As Range
Dim iRow As Long
Dim dRow As Long
Dim BVal, CVal, GVal, ARVal
Set Sh1 = Workbooks("転記元シート1.csv").Worksheets(1)
Set Sh2 = Workbooks("転記元シート2.csv").Worksheets(1)
Set Sh3 = Workbooks.Add.Worksheets(1)
dRow = 1
Set SearchRange = Intersect(Sh1.UsedRange, Sh1.Columns("F:F"))
For Each iRange In SearchRange
If Not WorksheetFunction.CountIfs(SearchRange, iRange.Value, SearchRange.Offset(, -5), ">" & iRange.Offset(, -5).Value) Then
iRow = iRange.Row
With Sh1
BVal = .Cells(iRow, "B").Value
CVal = .Cells(iRow, "C").Value
GVal = .Cells(iRow, "G").Value
ARVal = .Cells(iRow, "AR").Value
End With
With Sh3
Select Case True
Case BVal = "実行計画" And CVal = "計画"
.Cells(dRow, "Z").Value = GVal
.Cells(dRow, "AA").Value = ARVal
Case BVal = "手配計画" And CVal = "計画"
.Cells(dRow, "AB").Value = GVal
.Cells(dRow, "AC").Value = ARVal
Case BVal = "手配計画" And CVal = "見込"
.Cells(dRow, "AD").Value = GVal
.Cells(dRow, "AE").Value = ARVal
Case Else
dRow = dRow - 1
End Select
End With
dRow = dRow + 1
End If
Next
Set SearchRange = Intersect(Sh2.UsedRange, Sh2.Columns("E:E"))
For Each iRange In SearchRange
If Not WorksheetFunction.CountIfs(SearchRange, iRange.Value, SearchRange.Offset(, -4), ">" & iRange.Offset(, -4).Value) Then
iRow = iRange.Row
Sh3.Cells(dRow, "AF").Value = Sh2.Cells(iRow, "F")
Sh3.Cells(dRow, "AG").Value = Sh2.Cells(iRow, "AR")
dRow = dRow + 1
End If
Next
End Sub
たたき台を試作してみました。
おそらく希望の動作ではないのではないかと想像します。
不足の情報を補足お願いします。
（めざめるパワー） 2021/09/15(水) 14:21
転記先は1つのシートです。
F列義務Noで同じ値が複数ある場合の例を記載します。
これで不足情報は足りますでしょうか。
（5パターンすべて一番下のA列が"3"の情報を別ブックの該当列に転記したい場合です）
■転記元シート1
【B列：実行計画-C列：計画の場合】
A列 B列 C列 F列 G列 AR列
1 実行計画 計画 1234567 承認済 6/30
2 実行計画 計画 1234567 却下 7/1
3 実行計画 計画 1234567 承認済 8/1
⇒G列"承認済"をZ列に、AR列"8/1"をAA列に転記
【B列：手配計画-C列：計画の場合】
A列 B列 C列 F列 G列 AR列
1 手配計画 計画 9999999 承認済 6/30
2 手配計画 計画 9999999 却下 7/1
3 手配計画 計画 9999999 承認済 8/1
⇒G列"承認済"をAB列に、AR列"8/1"をAC列に転記
【B列：実行計画-C列：見込の場合】
A列 B列 C列 F列 G列 AR列
1 実行計画 見込 7777777 承認済 6/30
2 実行計画 見込 7777777 却下 7/1
3 実行計画 見込 7777777 承認済 8/1
⇒何もしない
【B列：手配計画-C列：見込の場合】
A列 B列 C列 F列 G列 AR列
1 手配計画 計画 1111111 承認済 6/30
2 手配計画 計画 1111111 却下 7/1
3 手配計画 計画 1111111 承認済 8/1
⇒G列"承認済"をAD列に、AR列"8/1"をAE列に転記
■転記元シート2
A列 E列 F列 AR列
1 5555555 承認済 6/30
2 5555555 却下 7/1
3 5555555 承認済 8/1
⇒F列"承認済"をAF列に、AR列"8/1"をAG列に転記
（わく） 2021/09/15(水) 17:19
で、どんな結果になるのか示してもらえませんか？そう書いたはずですが。
また、
(1)転記するのは「承認済」に限定しているんですか？ 当初はそうは書かれていなかったが。
(2)A列は数値は重ならないのでは？
＞転記元シート1のF列・シート2のE列の義務Noを転記先ブックのB列に探しに行き
・転記元シート1のF列の義務No
・シート２のE列の義務Noは、
必ず転記先ブックの特定シートのB列に必ずあるんですか？
またそれは一つしかないことが保証されているんですか？
なお、ひとことでいうと、転記元シート１と転記元シート２は何が違うんですか？
どういう性格のものなんですか？処理タイミングが違うだけ？担当者が違うだけ？
でもなさそうですが。イメージしにくいです。
（γ） 2021/09/15(水) 22:47
＞必ず転記先ブックの特定シートのB列に必ずあるんですか？ それが余計な心配であれば結構です。 既存のものになければ、追加作業が必要かと思いましたが、 それは別の作業として行われるわけですね。 私はdictionaryを多用して、 (1)二つの転記元データについては、それぞれ 義務番号 → 最新の日付であるA列番号 (2)書込先データについては、 義務番号 → 書込先の行番号 といったものを作成し、それを利用してコード化しました。
サンプルはテスト検証に使えるものを考えていましたが、 提示サンプルのA列番号が重なっていたり、 4番目のケースの内容が間違えていたりして サンプルデータとして支障がありました。手入れは簡単でしたが。
結果も提示していただくことは、質問者さんの考えを深める意味でも 決して無駄なことではないと思います。 文章にすることで見えてくることもあるからです。
参考までに現時点のコードを載せておきます。 dictionaryを使っているので分かりにくいかも知れません。 なお、エラー対応などは一切考えていませんので、適宜補足してください。
Option Explicit
Dim dic1 As Object Dim dic2 As Object Dim dic3 As Object Dim ws1 As Worksheet Dim ws2 As Worksheet Dim wsT As Worksheet
Sub test()
Dim lastRow&
Dim plan$, action$, 義務番号$
Dim p&, k&
Set ws1 = Worksheets("転記元シート1") '''■必要に応じて修正下さい
Set ws2 = Worksheets("転記元シート2") '''■必要に応じて修正下さい
Set wsT = Worksheets("転記先") '''■必要に応じて修正下さい
Set dic1 = CreateObject("Scripting.Dictionary")
Set dic2 = CreateObject("Scripting.Dictionary")
Set dic3 = CreateObject("Scripting.Dictionary")
Call 義務noに対応する書込先の行番号の取得
'転記元シート1の処理
With ws1
Call 最新番号一覧を取得1
lastRow = .Cells(Rows.Count, "A").End(xlUp).Row
For k = 2 To lastRow '一行目は見出しと仮定（■必要に応じて修正）
plan = .Cells(k, "B").Value
action = .Cells(k, "C").Value
義務番号 = .Cells(k, "F").Value
'A列番号が「義務番号ごとの最新日付に対応するA列番号」と一致すれば
If dic1(CStr(.Cells(k, "F").Value)) _
= CStr(.Cells(k, "A").Value) Then
p = dic3(義務番号) '転記先行番号
Select Case True
Case plan = "実行計画" And action = "計画"
wsT.Cells(p, "Z") = .Cells(k, "G")
wsT.Cells(p, "AA") = .Cells(k, "AR")
Case plan = "手配計画" And action = "計画"
wsT.Cells(p, "AB") = .Cells(k, "G")
wsT.Cells(p, "AC") = .Cells(k, "AR")
Case plan = "実行計画" And action = "見込"
Case plan = "手配計画" And action = "見込"
wsT.Cells(p, "AD") = .Cells(k, "G")
wsT.Cells(p, "AE") = .Cells(k, "AR")
End Select
End If
Next
End With
'転記元シート2の処理
With ws2
Call 最新番号一覧を取得2
lastRow = .Cells(Rows.Count, "A").End(xlUp).Row
For k = 2 To lastRow
'A列番号が「義務番号ごとの最新日付に対応するA列番号」と一致すれば
If dic2(CStr(.Cells(k, "E").Value)) _
= CStr(.Cells(k, "A").Value) Then
義務番号 = CStr(.Cells(k, "E").Value)
p = dic3(義務番号) '転記先行番号
wsT.Cells(p, "AF") = .Cells(k, "F")
wsT.Cells(p, "AG") = .Cells(k, "AR")
End If
Next
End With
End Sub
Function 最新番号一覧を取得1()
Dim lastRow&
Dim k&
Dim 番号$, 義務nr$
lastRow = ws1.Cells(Rows.Count, "A").End(xlUp).Row
For k = 2 To lastRow
番号 = CStr(ws1.Cells(k, "A").Value)
義務nr = CStr(ws1.Cells(k, "F").Value)
If dic1.exists(義務nr) Then
If 番号 > dic1(義務nr) Then dic1(義務nr) = 番号
Else
dic1(義務nr) = 番号
End If
Next
End Function
Function 最新番号一覧を取得2()
Dim lastRow&
Dim k&
Dim 番号$, 義務nr$
lastRow = ws2.Cells(Rows.Count, "A").End(xlUp).Row
For k = 2 To lastRow
番号 = CStr(ws2.Cells(k, "A").Value)
義務nr = CStr(ws2.Cells(k, "E").Value) ' Fにすると統一的になります。
If dic2.exists(義務nr) Then
If 番号 > dic2(義務nr) Then dic2(義務nr) = 番号
Else
dic2(義務nr) = 番号
End If
Next
End Function
Function 義務noに対応する書込先の行番号の取得()
Dim lastRow&, k&
lastRow = wsT.Cells(Rows.Count, "A").End(xlUp).Row
For k = 2 To lastRow
dic3(CStr(wsT.Cells(k, "B").Value)) = k
Next
End Function
なお、Dim宣言中の $や&などの記号は 型宣言文字と呼ばれ、 $はString, & はLongを意味します。 例えば、Dim k& は Dim k As Longと同等です。 （γ） 2021/09/16(木) 13:37
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.