excelmacroexcelmacro

～～～～～
Sub CompareAndCopyIP_WithPort()
    Dim ws1 As Worksheet, ws2 As Worksheet
    Dim ws3 As Worksheet, ws4 As Worksheet, ws5 As Worksheet
    Dim lastRow1 As Long, lastRow2 As Long
    Dim dict1 As Object, dict2 As Object
    Dim i As Long, key As Variant
    Dim outRow3 As Long, outRow4 As Long, outRow5 As Long
    
    ' シート参照
    Set ws1 = ThisWorkbook.Sheets("Sheet1")
    Set ws2 = ThisWorkbook.Sheets("Sheet2")
    
    ' Sheet3～5が存在しなければ作成
    On Error Resume Next
    Set ws3 = ThisWorkbook.Sheets("Sheet3")
    If ws3 Is Nothing Then
        Set ws3 = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
        ws3.Name = "Sheet3"
    End If
    
    Set ws4 = ThisWorkbook.Sheets("Sheet4")
    If ws4 Is Nothing Then
        Set ws4 = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
        ws4.Name = "Sheet4"
    End If
    
    Set ws5 = ThisWorkbook.Sheets("Sheet5")
    If ws5 Is Nothing Then
        Set ws5 = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
        ws5.Name = "Sheet5"
    End If
    On Error GoTo 0
    
    ' 出力先初期化
    ws3.Cells.Clear
    ws4.Cells.Clear
    ws5.Cells.Clear
    
    ' 最終行取得
    lastRow1 = ws1.Cells(ws1.Rows.Count, "A").End(xlUp).Row
    lastRow2 = ws2.Cells(ws2.Rows.Count, "A").End(xlUp).Row
    
    ' Dictionary作成
    Set dict1 = CreateObject("Scripting.Dictionary")
    Set dict2 = CreateObject("Scripting.Dictionary")
    
    ' Sheet1のIPをDictionaryに格納 (PORT, NAME1, NAME2)
    For i = 2 To lastRow1
        If ws1.Cells(i, 1).Value <> "" Then
            dict1(ws1.Cells(i, 1).Value) = Array(ws1.Cells(i, 2).Value, ws1.Cells(i, 3).Value, ws1.Cells(i, 4).Value)
        End If
    Next i
    
    ' Sheet2のIPをDictionaryに格納 (NAME1)
    For i = 2 To lastRow2
        If ws2.Cells(i, 1).Value <> "" Then
            dict2(ws2.Cells(i, 1).Value) = ws2.Cells(i, 2).Value
        End If
    Next i
    
    ' 出力行初期化
    outRow3 = 2
    outRow4 = 2
    outRow5 = 2
    
    ' ヘッダー行
    ws3.Range("A1:D1").Value = Array("IP", "PORT", "NAME1", "NAME2")
    ws4.Range("A1:B1").Value = Array("IP", "NAME1")
    ws5.Range("A1:D1").Value = Array("IP", "PORT", "NAME1", "NAME2")
    
    ' Sheet1にしかないIP → Sheet3
    For Each key In dict1.Keys
        If Not dict2.Exists(key) Then
            ws3.Cells(outRow3, 1).Value = key
            ws3.Cells(outRow3, 2).Value = dict1(key)(0)
            ws3.Cells(outRow3, 3).Value = dict1(key)(1)
            ws3.Cells(outRow3, 4).Value = dict1(key)(2)
            outRow3 = outRow3 + 1
        End If
    Next key
    
    ' Sheet2にしかないIP → Sheet4
    For Each key In dict2.Keys
        If Not dict1.Exists(key) Then
            ws4.Cells(outRow4, 1).Value = key
            ws4.Cells(outRow4, 2).Value = dict2(key)
            outRow4 = outRow4 + 1
        End If
    Next key
    
    ' 両方にあるIP → Sheet5 (Sheet1のデータをコピー)
    For Each key In dict1.Keys
        If dict2.Exists(key) Then
            ws5.Cells(outRow5, 1).Value = key
            ws5.Cells(outRow5, 2).Value = dict1(key)(0)
            ws5.Cells(outRow5, 3).Value = dict1(key)(1)
            ws5.Cells(outRow5, 4).Value = dict1(key)(2)
            outRow5 = outRow5 + 1
        End If
    Next key
    
    MsgBox "処理が完了しました！", vbInformation
End Sub
～～～～～
Sub CountNamesToSheet2()
    Dim wsSrc As Worksheet, wsDst As Worksheet
    Dim dict As Object
    Dim lastRow As Long, i As Long, j As Long
    Dim nameVal As Variant
    Dim tmpName As String, tmpCount As Long
    
    ' 元データのシート
    Set wsSrc = ThisWorkbook.Sheets("Sheet1")
    
    ' 出力先シート（なければ作成）
    On Error Resume Next
    Set wsDst = ThisWorkbook.Sheets("Sheet2")
    If wsDst Is Nothing Then
        Set wsDst = ThisWorkbook.Sheets.Add
        wsDst.Name = "Sheet2"
    End If
    On Error GoTo 0
    
    ' NAME列の最終行を取得（B列を想定）
    lastRow = wsSrc.Cells(wsSrc.Rows.Count, "B").End(xlUp).Row
    
    ' Dictionaryで集計
    Set dict = CreateObject("Scripting.Dictionary")
    For i = 2 To lastRow ' ヘッダを除いて2行目から
        nameVal = Trim(wsSrc.Cells(i, "B").Value)
        If nameVal <> "" Then
            If dict.exists(nameVal) Then
                dict(nameVal) = dict(nameVal) + 1
            Else
                dict.Add nameVal, 1
            End If
        End If
    Next i
    
    ' 出力先を初期化
    wsDst.Cells.Clear
    wsDst.Range("A1").Value = "NAME"
    wsDst.Range("B1").Value = "COUNT"
    
    ' Dictionaryを配列にして並べ替え
    Dim arr(), count As Long
    count = dict.Count
    ReDim arr(1 To count, 1 To 2)
    
    i = 0
    For Each nameVal In dict.Keys
        i = i + 1
        arr(i, 1) = nameVal
        arr(i, 2) = dict(nameVal)
    Next
    
    ' COUNTで降順ソート（バブルソート）
    For i = 1 To count - 1
        For j = i + 1 To count
            If arr(i, 2) < arr(j, 2) Then
                tmpName = arr(i, 1)
                tmpCount = arr(i, 2)
                arr(i, 1) = arr(j, 1)
                arr(i, 2) = arr(j, 2)
                arr(j, 1) = tmpName
                arr(j, 2) = tmpCount
            End If
        Next j
    Next i
    
    ' Sheet2へ書き込み
    wsDst.Range("A2").Resize(count, 2).Value = arr
    
    MsgBox "Sheet2に集計結果を出力しました！", vbInformation
End Sub
～～～～～