質問をすることでしか得られない、回答やアドバイスがある。

15分調べてもわからないことは、質問しよう!

新規登録して質問してみよう
ただいま回答率
85.50%
VBA

VBAはオブジェクト指向プログラミング言語のひとつで、マクロを作成によりExcelなどのOffice業務を自動化することができます。

Q&A

解決済

1回答

446閲覧

VBA 照合カウント計算

jabe

総合スコア43

VBA

VBAはオブジェクト指向プログラミング言語のひとつで、マクロを作成によりExcelなどのOffice業務を自動化することができます。

0グッド

0クリップ

投稿2022/04/07 13:14

編集2022/04/09 10:28

●転記元excel
イメージ説明
●転記先excel
イメージ説明

実現したいこと

●完成状態
イメージ説明
テーマ:転記元excelの共通キーと転記先excelを部分照合し、数値をカウント計算
部分照合キー:yyyy/mm
①転記元excelのセルA3から最終行までの値に対して、
転記先excelのセルA2から最終行までを部分照合し以下処理を実行
合致:合致年月のF工程セル値有無チェック
空白の場合:セルへ1記入
空白でない場合:+1カウント
不一致:処理を飛ばす

発生している問題・エラーメッセージ

yyyy/mmで部分検索を狙ったのですが、合致できず全てカウントされない状態になってしまいます。

該当のソースコード

Sub 照合転記() Const source As String = "C:\Users\xxx\Desktop\yyy\00_VBA\照合転記" '転記元パス Const copy As String = "C:\Users\xxx\Desktop\yyy\00_VBA\照合転記" Const cn As String = "転記先.xlsx" Dim slastline As String '転記元最終行 Dim clastline As String '転記先最終行 Dim cWs As Worksheet '転記先シート変数 Dim i As Integer '出荷日予定日繰返し回数 Dim sfresult As Range 'F工程検索キー Dim cfresult As Range 'F工程検索結果 Application.ScreenUpdating = False '画面チラツキ防止 Workbooks.Open Filename:=copy & "\" & cn Set cWb = ActiveWorkbook Set cWs = cWb.Worksheets("転記先") clastline = cWs.Cells(Rows.Count, "A").End(xlUp).Row Set sWb = ThisWorkbook Set sWs = sWb.Worksheets("転記元") slastline = sWs.Cells(Rows.Count, "A").End(xlUp).Row cWs.Range(Cells(2, 3), Cells(clastline, 3)).ClearContents For i = 3 To slastline '転記元データ分繰り返す Set sfresult = sWs.Cells(i, 1) sfresult = Left(sfresult, 7) 'yyyy/mm取出し  If sfresult = "" Then '空白飛ばし GoTo next1: End If Set cfresult = cWb.Worksheets("転記先").Range(Cells(2, 1), Cells(clastline, 1)).Find(sfresult, lookat:=xlPart) 'yyyy/mmで部分検索 If cfresult Is Nothing Then '不一致は、何も処理を行わない ElseIf Not cfresult Is Nothing Then '合致は、以下条件式へ進む If cWs.Cells(cfresult.Row, 3).Value <> "" Then 'F工程欄に値が入っている場合は以下処理 Cells(cfresult.Row, 3).Value = Cells(cfresult.Row, 3).Value + 1 ElseIf Not cfresult Is Nothing Then 'F工程乱に値が入っていない場合は以下処理 Cells(cfresult.Row, 3).Value = 1 End If next1: End If Next i Application.DisplayAlerts = False ActiveWorkbook.SaveAs Filename:=copy & "\" & "転記先.xlsx" '保存 ActiveWorkbook.Close Application.DisplayAlerts = True 'メッセージ表示※上書き保存 Application.ScreenUpdating = True '画面チラツキ防止 End sub

補足

転記元:年月セルは日付型
転記先:F工程セルは日付型

また、素人知識でこの方法しか分からない為、以下気になる点もあります。
転記元excelの年月日は大量にある為、私の一行ずつ照合する方法以外にも良い方法(プログラム処理が速い)がありましたら、教えていただけると助かります。

気になる質問をクリップする

クリップした質問は、後からいつでもMYページで確認できます。

またクリップした質問に回答があった際、通知やメールを受け取ることができます。

バッドをするには、ログインかつ

こちらの条件を満たす必要があります。

meg_

2022/04/07 13:45

コードが見づらいのでマークダウンでひとまとめに記入いただけませんか? また求める結果の表も提示いただけると分かりやすいです。
jabe

2022/04/07 15:06

連絡ありがとうございます。 完成状態とマークダウンでひとまとめにさせていただきました。
meg_

2022/04/07 16:19

> yyyy/mmで部分検索を狙ったのですが、合致できず全てカウントされない状態になってしまいます。 シート検索で例えば「2022/01」を検索してもヒットしませんよね。VBAでも同じ結果になっているのではないでしょうか? 検索機能ではなくセル値の年月の比較を一つずつ行ってはどうでしょうか?
meg_

2022/04/07 16:25

あるいは転記先の日付部分が全て1日ならば、「2022/1/1」等で検索(数式)すれば良いのかもしれません。
tatsu99

2022/04/08 00:58

>転記先:F工程セルは日付型 これは、「転記先:A列の年月は日付型」の誤りですよね。
jabe

2022/04/09 01:25

megさん 回答ありがとうございます。試してみます。 tatsu99さん 連絡ありがとうございます。申し訳ありません、おっしゃる通りになります。
guest

回答1

0

ベストアンサー

diff

1- Dim sfresult As Range 'F工程検索キー 2+ Dim sfresult As String 'F工程検索キー

diff

1- Set sfresult = sWs.Cells(i, 1) 2- sfresult = Left(sfresult, 7) 'yyyy/mm取出し 3+ sfresult = Format(sWs.Cells(i, 1), "yyyy年m月") 'yyyy年m月に変換

diff

1- Set cfresult = cWb.Worksheets("転記先").Range(Cells(2, 1), Cells(clastline, 1)).Find(sfresult, lookat:=xlPart) 'yyyy/mmで部分検索 2+ Set cfresult = cWb.Worksheets("転記先").Range(Cells(2, 1), Cells(clastline, 1)).Find(sfresult,LookIn:=xlValues) 'yyyy年m月で検索

で、とりあえず動くのではないでしょうか。

速度的な改善案としては
Scripting.Dictionaryを使って集計してから転記するのがいいのではないでしょうか。
参考:https://www.239-programing.com/excel-vba/dco/dco014.html

まぁ。VBAでなくても、ピボットテーブルでいいんじゃないのとも思ったりはしますが。

投稿2022/04/07 20:55

xail2222

総合スコア1497

バッドをするには、ログインかつ

こちらの条件を満たす必要があります。

jabe

2022/04/09 01:28

回答と参考情報ありがとうございます。 狙い通りプログラムを動作させる事が出来ました。 検索方法も、formatで変換し、値で検索する方法を理解する事が出来ました。 助かりました。
guest

あなたの回答

tips

太字

斜体

打ち消し線

見出し

引用テキストの挿入

コードの挿入

リンクの挿入

リストの挿入

番号リストの挿入

表の挿入

水平線の挿入

プレビュー

15分調べてもわからないことは
teratailで質問しよう!

ただいまの回答率
85.50%

質問をまとめることで
思考を整理して素早く解決

テンプレート機能で
簡単に質問をまとめる

質問する

関連した質問