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

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

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

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

解決済

VBA 照合カウント計算 その2

jabe
jabe

総合スコア35

VBA

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

3回答

0評価

0クリップ

482閲覧

投稿2022/04/11 12:20

前提

●転記元
シート1
イメージ説明
●転記先※完成状態
シート2
イメージ説明
●転記先※完成状態
シート3
イメージ説明
ここに質問の内容を詳しく書いてください。
(例)
TypeScriptで●●なシステムを作っています。
■■な機能を実装中に以下のエラーメッセージが発生しました。

実現したいこと

以下VBAを作成しました。
今後データが多くなる為現状のやり方の場合動作が遅くなる恐れがある為、
配列等を用いて処理速度が速いプログラムを作成したいのですが、
方法がさっぱり分からない為、作成方法を教えていただきたいです。

転記元excelの共通キーと転記先excelを部分照合し、数値をカウント計算
①転記元excelのC列(C12〜C1300)と転記先excelのA列(A2〜A366)を照合して以下処理を実行
合致:合致年月のD列(D12〜)でセル値有無チェック
空白の場合:セルへ1記入
空白でない場合:+1カウント
不一致:処理を飛ばす
上記サイクルを以下ステップで繰り返す。
ステップ②
シート1     シート2   シート2  
照合       照合     セル入力
転記元:D列 → 転記先:A →転記先:E列
転記元:E列 → 転記先:A →転記先:F列
転記元:F列 → 転記先:A →転記先:G列
ステップ③
シート1     シート3   シート3
転記元:B列 → 転記先:A →転記先:B列

該当のソースコード

Sub 照合転記() Const source As String = "C:\Users\xxx\Desktop\yy\00_VBA\照合転記2" '転記元パス Const copy As String = "C:\Users\xxx\Desktop\yy\00_VBA\照合転記2" Const cn As String = "転記先.xlsx" Dim sslastline As String '転記元A最終行 Dim shlastline As String '転記元B最終行 Dim sklastline As String '転記先C最終行 Dim ssylastline As String '転記元D最終行 Dim ssyylastline As String '転記元E最終行 Dim clastline As String '転記先日付最終行 Dim sWb As Workbook '転記元ファイル変' Dim sWs As Worksheet '転記元ファイル変数 Dim cWb As Workbook '転記先ファイル変数 Dim cWs As Worksheet '転記先シート変数 Dim cWs1 As Worksheet '転記先製作指示台数シート変数 Dim a As Integer 'A繰返し回数 Dim b As Integer 'B繰返し回数 Dim c As Integer 'C繰返し回数 Dim d As Integer 'D繰返し回数 Dim e As Integer 'E繰返し回数 Dim sresult As String 'A検索キー Dim hresult As String 'B検索キー Dim kresult As String 'C検索キー Dim syresult As String 'D検索キー Dim syyresult As String 'E検索キー Dim csresult As Range 'A検索結果 Dim chresult As Range 'B検索結果 Dim ckresult As Range 'C検索結果 Dim csyresult As Range 'D検索結果 Dim csyyresult As Range 'E検索結果 Application.ScreenUpdating = False '画面チラツキ防止 Workbooks.Open Filename:=copy & "\" & cn '転記先ファイルを開く Set cWb = ActiveWorkbook Set cWs = cWb.Worksheets("シート2") Set cWs1 = cWb.Worksheets("シート3") clastline = cWs.Cells(Rows.Count, "A").End(xlUp).Row '転記先ファイル入力シート最終行定義 c1lastline = cWs1.Cells(Rows.Count, "A").End(xlUp).Row Set sWb = ThisWorkbook Set sWs = sWb.Worksheets("シート1") sslastline = sWs.Cells(Rows.Count, "C").End(xlUp).Row shlastline = sWs.Cells(Rows.Count, "D").End(xlUp).Row sklastline = sWs.Cells(Rows.Count, "E").End(xlUp).Row ssylastline = sWs.Cells(Rows.Count, "F").End(xlUp).Row ssyylastline = sWs.Cells(Rows.Count, "B").End(xlUp).Row cWs.Range(Cells(2, 4), Cells(clastline, 7)).ClearContents '転記先セル値削除 '//A For a = 12 To sslastline '転記元の12行目から最終行まで1行ずつチェック sresult = Format(sWs.Cells(a, 3), "yyyy/m/d") If sresult = "" Then GoTo next1: '空白飛ばし End If Set csresult = cWb.Worksheets("シート2").Range(Cells(2, 1), Cells(clastline, 1)).Find(sresult, LookIn:=xlValues) '転記先との比較 If Not csresult Is Nothing Then '合致000 If cWs.Cells(csresult.Row, 4).Value <> "" Then 'A列に値が入っていれば Cells(csresult.Row, 4).Value = Cells(csresult.Row, 4).Value + 1 ElseIf Not csresult Is Nothing Then 'A列に値が入っていなければ Cells(csresult.Row, 4).Value = 1 End If next1: End If Next a '//B For b = 12 To shlastline '転記元の12行目から最終行まで1行ずつチェック hresult = Format(sWs.Cells(b, 4), "yyyy/m/d") If hresult = "" Then GoTo next2: '空白飛ばし End If Set chresult = cWb.Worksheets("シート2").Range(Cells(2, 1), Cells(clastline, 1)).Find(hresult, LookIn:=xlValues) '転記先との比較 If Not chresult Is Nothing Then '合致 If cWs.Cells(chresult.Row, 5).Value <> "" Then 'B列に値が入っていれば Cells(chresult.Row, 5).Value = Cells(chresult.Row, 5).Value + 1 ElseIf Not chresult Is Nothing Then 'B列に値が入っていなければ Cells(chresult.Row, 5).Value = 1 End If next2: End If Next b '//C For c = 12 To sklastline '転記元の12行目から最終行まで1行ずつチェック kresult = Format(sWs.Cells(c, 5), "yyyy/m/d") If kresult = "" Then GoTo next3: '空白飛ばし End If Set ckresult = cWb.Worksheets("シート2").Range(Cells(2, 1), Cells(clastline, 1)).Find(kresult, LookIn:=xlValues) '転記先との比較 If Not ckresult Is Nothing Then '合致 If cWs.Cells(ckresult.Row, 6).Value <> "" Then 'C列に値が入っていれば Cells(ckresult.Row, 6).Value = Cells(ckresult.Row, 6).Value + 1 ElseIf Not ckresult Is Nothing Then 'C列に値が入っていなければ Cells(ckresult.Row, 6).Value = 1 End If next3: End If Next c '//D For d = 12 To ssylastline '転記元の12行目から最終行まで1行ずつチェック syresult = Format(sWs.Cells(d, 6), "yyyy/m/d") If syresult = "" Then GoTo next4: '空白飛ばし End If Set csyresult = cWb.Worksheets("シート2").Range(Cells(2, 1), Cells(clastline, 1)).Find(syresult, LookIn:=xlValues) '転記先との比較 If Not csyresult Is Nothing Then '合致 If cWs.Cells(csyresult.Row, 7).Value <> "" Then 'D列に値が入っていれば Cells(csyresult.Row, 7).Value = Cells(csyresult.Row, 7).Value + 1 ElseIf Not csyresult Is Nothing Then 'D列に値が入っていなければ Cells(csyresult.Row, 7).Value = 1 End If next4: End If Next d '//E cWb.Worksheets("シート3").Activate cWs1.Range(Cells(2, 2), Cells(clastline, 2)).ClearContents For e = 12 To ssyylastline '転記元の2行目から最終行まで1行ずつチェック syyresult = Format(sWs.Cells(e, 2), "yyyy年m月") 'yyyy年m月に変換 If syyresult = "" Then GoTo next5: '空白飛ばし End If Set csyyresult = cWb.Worksheets("シート3").Range(Cells(2, 1), Cells(c1lastline, 1)).Find(syyresult, LookIn:=xlValues) '転記先との比較 If Not csyyresult Is Nothing Then '合致 If cWs1.Cells(csyyresult.Row, 2).Value <> "" Then 'E列に値が入っていれば Cells(csyyresult.Row, 2).Value = Cells(csyyresult.Row, 2).Value + 1 Else '値が入っていなければ Cells(csyyresult.Row, 2).Value = 1 End If next5: End If Next e Application.DisplayAlerts = False cWb.Worksheets("シート2").Activate '入力シートへ戻す ActiveWorkbook.SaveAs Filename:=copy & "\" & "転記先.xlsx" '保存 ActiveWorkbook.Close Application.DisplayAlerts = True 'メッセージ表示※上書き保存 Application.ScreenUpdating = True '画面チラツキ防止 MsgBox "更新完了" End Sub

良い質問の評価を上げる

以下のような質問は評価を上げましょう

  • 質問内容が明確
  • 自分も答えを知りたい
  • 質問者以外のユーザにも役立つ

評価が高い質問は、TOPページの「注目」タブのフィードに表示されやすくなります。

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

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

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

teratailでは下記のような質問を「具体的に困っていることがない質問」、「サイトポリシーに違反する質問」と定義し、推奨していません。

  • プログラミングに関係のない質問
  • やってほしいことだけを記載した丸投げの質問
  • 問題・課題が含まれていない質問
  • 意図的に内容が抹消された質問
  • 過去に投稿した質問と同じ内容の質問
  • 広告と受け取られるような投稿

評価を下げると、トップページの「アクティブ」「注目」タブのフィードに表示されにくくなります。

まだ回答がついていません

会員登録して回答してみよう

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

ただいまの回答率
87.20%

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

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

質問する

関連した質問

同じタグがついた質問を見る

VBA

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