注文書籍データを出版社別シートに分別転記する エクセル

Option Explicit

Function wb() As Workbook
    Set wb = Workbooks("FAX注文書作成.xlsm")
End Function

Function wsT() As Worksheet
    Set wsT = wb.Worksheets("抽出データ")
End Function

Function wsS() As Worksheet
    Set wsS = wb.Worksheets("出版社リスト")
End Function

Sub ソート()
    Dim Hsrow As Long
        With wsT
          .Select
          Hsrow = .Cells(Rows.Count, 1).End(xlUp).Row
          .Range(.Cells(2, 1), .Cells(Hsrow, 7)) _
                   .Sort Key1:=.Cells(1, 3), order1:=xlAscending
        End With
End Sub

Sub 出版社名抽出()
    Dim tRange, dRange As Range
    Dim buf, buf2 As Variant
    Dim myDic As Object
    Dim Aho As Variant
    Dim HaRow, i As Long
    Dim myKeys As Variant
        With wsT
            .Select
            Aho = .Range("C2").Value
            HaRow = .Cells(Rows.Count, 6).End(xlUp).Row
        End With
        If HaRow > 2 Then
            Set tRange = wsT.Range("C2:C" & HaRow)
            buf = tRange
            Set myDic = CreateObject("Scripting.Dictionary")
            On Error Resume Next
            For i = 1 To HaRow
                myDic.Add buf(i, 1), ""
            Next i
            On Error GoTo 0
            With wsS
                Set dRange = .Range(.Range("A1"), _
                                    .Range("A" & myDic.Count))
                buf2 = dRange
                myKeys = myDic.keys
                
                If myDic.Count = 1 Then
                    .Range("A1").Value = Aho
                Else
                    For i = 1 To myDic.Count
                    buf2(i, 1) = myKeys(i - 1)
                    Next i
                    dRange = buf2
                End If
            End With
        Else
            wsS.Range("A1").Value = Aho
        End If
    End Sub

Sub シート作成()
 Dim SuRow, t As Long
 Dim Vn As Variant
    With wsS
       .Activate
       SuRow = .Cells(Rows.Count, 1).End(xlUp).Row
       For t = 1 To SuRow
          Vn = .Range("A" & t).Value
          Worksheets.Add After:=Worksheets(Worksheets.Count)
          ActiveSheet.Name = Vn
          .Activate
       Next t
    End With
 End Sub

Sub 発注振り分け()
    Dim SuRow, t, HaRow, s, N As Long
    Dim Vn As Variant
        With wsS
            .Activate
            SuRow = .Cells(Rows.Count, 1).End(xlUp).Row
            For t = 1 To SuRow
                Vn = .Range("A" & t).Value
                wsT.Activate
                HaRow = wsT.Cells(Rows.Count, 6).End(xlUp).Row
                s = 1
                For N = 1 To HaRow
                    If wsT.Range("C" & N).Value = Vn Then
                        wsT.Rows(N).Copy Destination:=Worksheets(Vn) _
                                                .Range("A" & s)
                        s = s + 1
                        Worksheets(Vn).Columns("A:G").AutoFit
                    End If
                    wsT.Activate
                Next N
                .Activate
            Next t
        End With
End Sub

Sub 注文データまとめ()
        Call Module2.ソート
        Call Module2.出版社名抽出
        Call Module2.シート作成
        Call Module2.発注振り分け
        Worksheets("操作ボタン").Select
        Range("A1").Select
End Sub