VBA の学習 No title
No License VBA
2021年03月30日
Copy Clone
Attribute VB_Name = "DataCount"
Option Explicit

Sub test()
    'test�����p�v���V�[�W��
    '�T���v��������o�^

    Dim a As Worksheet: Set a = ThisWorkbook.Worksheets("�O���t")
    Dim b As Worksheet: Set b = ThisWorkbook.Worksheets("�W�v����")
    Dim c As Variant: Set c = CreateObject("scripting.dictionary")
    Dim d As String: d = "I"
    Dim e As Range: Set e = Range("B5")
    
    Call MyDictionaryMain(a, b, c, d, e)

    Set a = Nothing
    Set b = Nothing
    Set c = Nothing
    Set e = Nothing
    
End Sub

Public Sub MyDictionaryMain(TargetWs As Worksheet, TargetWs2 As Worksheet, TargetMyDic As Variant, TargetKey As String, TargetRng As Range)
    '��P�����F�]�L�惏�[�N�V�[�g�I�u�W�F�N�g
    '��Q�����F�]�L�����[�N�V�[�g�I�u�W�F�N�g
    '��R�����F�W�v���ʔz��
    '��S�����F�W�v�p�L�[��
    '��T�����F�]�L��Range
    
    '�W�v�R���g�[���v���V�[�W��
    Call MyDictionary(TargetWs, TargetWs2, TargetMyDic, TargetKey, TargetRng)

    Call OutputDic(TargetWs, TargetWs2, TargetMyDic, TargetKey, TargetRng)

End Sub

Private Sub MyDictionary(TargetWs As Worksheet, TargetWs2 As Worksheet, TargetMyDic As Variant, TargetKey As String, TargetRng As Range)
    '��P�����F�]�L�惏�[�N�V�[�g�I�u�W�F�N�g
    '��Q�����F�]�L�����[�N�V�[�g�I�u�W�F�N�g
    '��R�����F�W�v���ʔz��
    '��S�����F�W�v�p�L�[��
    '��T�����F�]�L��Range

    '�e���ڂ̍��v���擾�i�A�z�z������鎖�ɂ��ȒP�ɏo����j
    Dim i As Long, j As Long
    
    '�\���֖ؑ���
    Application.ScreenUpdating = False

    TargetWs.Cells.ClearContents '�\����x�N���A

    '�\�̍ŏI�s���擾
    Dim lastRow As Long: lastRow = TargetWs2.Cells(Rows.Count, TargetKey).End(xlUp).Row
    
    '�\�̂��ׂĂ������ɓo�^
    For i = 5 To lastRow  '�f�[�^�J�n�s5�s�`�ŏI�s�܂�
        
        If TargetMyDic.Exists(TargetWs2.Cells(i, TargetKey).Value) Then        '�L�[�̑��݊m�F
            '�L�[�̓o�^������ꍇ�́A����(myDic(Cells(i,1).value)�˂���́A�A�z�z��ł���A�l�������Ă���
            TargetMyDic(TargetWs2.Cells(i, TargetKey).Value) = TargetMyDic(TargetWs2.Cells(i, TargetKey).Value) + 1
        Else
            TargetMyDic.Add TargetWs2.Cells(i, TargetKey).Value, 1     '�L�[�̓o�^�������ꍇ�́A�lj�����
        End If
    Next
                    
End Sub

Private Sub OutputDic(TargetWs As Worksheet, TargetWs2 As Worksheet, TargetMyDic As Variant, TargetKey As String, TargetRng As Range)
    '��P�����F�]�L�惏�[�N�V�[�g�I�u�W�F�N�g
    '��Q�����F�]�L�����[�N�V�[�g�I�u�W�F�N�g
    '��R�����F�W�v���ʔz��
    '��S�����F�W�v�p�L�[��
    '��T�����F�]�L��Range
   
    '�A�z�z��̏����o��
    Dim OutputArr: Dim OutputKey
    ReDim OutputArr(TargetMyDic.Count - 1, 1)
        
    Dim j: j = 0

    'MyDictionary�Ŏ擾�������e��Outout�p�z��ɑ��
    For Each OutputKey In TargetMyDic
        OutputArr(j, 0) = OutputKey
        OutputArr(j, 1) = TargetMyDic.Item(OutputKey)
        j = j + 1
    Next
    
    Dim lastRow As Long: lastRow = TargetMyDic.Count            '�z��̍ŏI�s��(�傫��)
    
    '�]�L��A�h���X
    
    TargetWs.TargetRng.Resize(lastRow, 2) = OutputArr
    
    '�\���֖ؑ���
    Application.ScreenUpdating = True
 
 End Sub
Attribute VB_Name = "DataCount"
Option Explicit

Sub test()
    'test�����p�v���V�[�W��
    '�T���v��������o�^

    Dim a As Worksheet: Set a = ThisWorkbook.Worksheets("�O���t")
    Dim b As Worksheet: Set b = ThisWorkbook.Worksheets("�W�v����")
    Dim c As Variant: Set c = CreateObject("scripting.dictionary")
    Dim d As String: d = "I"
    Dim e As Range: Set e = Range("B5")
    
    Call MyDictionaryMain(a, b, c, d, e)

    Set a = Nothing
    Set b = Nothing
    Set c = Nothing
    Set e = Nothing
    
End Sub

Public Sub MyDictionaryMain(TargetWs As Worksheet, TargetWs2 As Worksheet, TargetMyDic As Variant, TargetKey As String, TargetRng As Range)
    '��P�����F�]�L�惏�[�N�V�[�g�I�u�W�F�N�g
    '��Q�����F�]�L�����[�N�V�[�g�I�u�W�F�N�g
    '��R�����F�W�v���ʔz��
    '��S�����F�W�v�p�L�[��
    '��T�����F�]�L��Range
    
    '�W�v�R���g�[���v���V�[�W��
    Call MyDictionary(TargetWs, TargetWs2, TargetMyDic, TargetKey, TargetRng)

    Call OutputDic(TargetWs, TargetWs2, TargetMyDic, TargetKey, TargetRng)

End Sub

Private Sub MyDictionary(TargetWs As Worksheet, TargetWs2 As Worksheet, TargetMyDic As Variant, TargetKey As String, TargetRng As Range)
    '��P�����F�]�L�惏�[�N�V�[�g�I�u�W�F�N�g
    '��Q�����F�]�L�����[�N�V�[�g�I�u�W�F�N�g
    '��R�����F�W�v���ʔz��
    '��S�����F�W�v�p�L�[��
    '��T�����F�]�L��Range

    '�e���ڂ̍��v���擾�i�A�z�z������鎖�ɂ��ȒP�ɏo����j
    Dim i As Long, j As Long
    
    '�\���֖ؑ���
    Application.ScreenUpdating = False

    TargetWs.Cells.ClearContents '�\����x�N���A

    '�\�̍ŏI�s���擾
    Dim lastRow As Long: lastRow = TargetWs2.Cells(Rows.Count, TargetKey).End(xlUp).Row
    
    '�\�̂��ׂĂ������ɓo�^
    For i = 5 To lastRow  '�f�[�^�J�n�s5�s�`�ŏI�s�܂�
        
        If TargetMyDic.Exists(TargetWs2.Cells(i, TargetKey).Value) Then        '�L�[�̑��݊m�F
            '�L�[�̓o�^������ꍇ�́A����(myDic(Cells(i,1).value)�˂���́A�A�z�z��ł���A�l�������Ă���
            TargetMyDic(TargetWs2.Cells(i, TargetKey).Value) = TargetMyDic(TargetWs2.Cells(i, TargetKey).Value) + 1
        Else
            TargetMyDic.Add TargetWs2.Cells(i, TargetKey).Value, 1     '�L�[�̓o�^�������ꍇ�́A�lj�����
        End If
    Next
                    
End Sub

Private Sub OutputDic(TargetWs As Worksheet, TargetWs2 As Worksheet, TargetMyDic As Variant, TargetKey As String, TargetRng As Range)
    '��P�����F�]�L�惏�[�N�V�[�g�I�u�W�F�N�g
    '��Q�����F�]�L�����[�N�V�[�g�I�u�W�F�N�g
    '��R�����F�W�v���ʔz��
    '��S�����F�W�v�p�L�[��
    '��T�����F�]�L��Range
   
    '�A�z�z��̏����o��
    Dim OutputArr: Dim OutputKey
    ReDim OutputArr(TargetMyDic.Count - 1, 1)
        
    Dim j: j = 0

    'MyDictionary�Ŏ擾�������e��Outout�p�z��ɑ��
    For Each OutputKey In TargetMyDic
        OutputArr(j, 0) = OutputKey
        OutputArr(j, 1) = TargetMyDic.Item(OutputKey)
        j = j + 1
    Next
    
    Dim lastRow As Long: lastRow = TargetMyDic.Count            '�z��̍ŏI�s��(�傫��)
    
    '�]�L��A�h���X
    
    TargetWs.TargetRng.Resize(lastRow, 2) = OutputArr
    
    '�\���֖ؑ���
    Application.ScreenUpdating = True
 
 End Sub
No one still commented. Please first comment.