エクセルFAX注文書 Webの書誌データ収集と集約のVBA

Option Explicit

Sub 書誌データ登録()
'変数の宣言
    Dim BN, Boname As String
    Dim BS, Bosname As String
    Dim SH, Shuname As String
    Dim WR, Wriname As String
    Dim CO, Cost As String
    Dim ISB, IsCode As String
    Dim i, nRow As Long
    Dim mysasu As Variant
    Dim mymsg1, mymsg2, mytitle1, mytitle2, mykyaku As Variant
'抽出データシートのデータ項目を記述
        Worksheets("抽出データ").Select
        Range("A1").Value = "ISBN"
        Range("B1").Value = "書名"
        Range("C1").Value = "出版社名"
        Range("D1").Value = "著者名"
        Range("E1").Value = "本体価格"
        Range("F1").Value = "冊数"
        Range("G1").Value = "客注名"
'Ａ列を使ってデータ入力済の行数を数える
        nRow = Range("A1").CurrentRegion.Rows.Count + 1
'Webからコピペした書誌データの取り込み
    '書誌データ貼付シートでのデータ取り出し
        With Worksheets("書誌データ貼付")
            .Select
            BN = .Range("H2").Value
            BS = .Range("H3").Value
            SH = .Range("H4").Value
            WR = .Range("H5").Value
            CO = .Range("H6").Value
            ISB = .Range("H7").Value
            Boname = .Range(BN)
            If Boname = "" Then
                MsgBox "書名が見つかりません。" & vbCrLf & _
                "初めからやり直してください。", vbExclamation, "FAX注文書作成"
                Exit Sub
            End If
            Bosname = .Range(BS)
            Shuname = .Range(SH)
            Wriname = .Range(WR)
            Cost = .Range(CO)
            IsCode = .Range(ISB)
            For i = 2 To 7
                If .Cells(i, 9) = "" Then
                .Cells(i, 9) = " "
                End If
            Next i
            Boname = Right(Boname, _
                            Len(Boname) - InStr(Boname, .Range("I2")))
            Bosname = Right(Bosname, _
                            Len(Bosname) - InStr(Bosname, .Range("I3")))
            Shuname = Right(Shuname, _
                            Len(Shuname) - InStr(Shuname, .Range("I4")))
            Wriname = Right(Wriname, _
                            Len(Wriname) - InStr(Wriname, .Range("I5")))
            Cost = Right(Cost, Len(Cost) - InStr(Cost, .Range("I6")))
            IsCode = Right(IsCode, _
                            Len(IsCode) - InStr(IsCode, .Range("I7")))
        End With
    '抽出シートへデータを転記
        With Worksheets("抽出データ")
            .Select
        '書名
            .Range("B" & nRow) = Boname
        '副書名
            .Range("I" & nRow) = Bosname
        '書名連結
            .Range("B" & nRow) = .Range("B" & nRow) _
                                            & " " & .Range("I" & nRow)
            .Range("I" & nRow) = ""
        '出版社
            .Range("C" & nRow) = Shuname
        '著者
            .Range("D" & nRow) = Wriname
        '本体価格
            .Range("E" & nRow) = Cost
        'ＩＳＢＮ
            With .Range("A" & nRow)
                .Value = IsCode
                .NumberFormatLocal = "0_ "
            End With
        End With
'利用者からの情報取得
        With Worksheets("抽出データ")
            .Select
        '冊数
            mymsg1 = "冊数を記入ください。"
            mytitle1 = "冊数"
            mysasu = Application.InputBox(prompt:=mymsg1, _
                                                Title:=mytitle1, Type:=1)
            If mysasu = "" Or mysasu = False Then
                MsgBox "数量が入力されていませんが、" & vbCrLf & _
                "数量1冊として登録します。", vbExclamation, "FAX注文書作成"
                mysasu = 1
            End If
            .Range("F" & nRow).Value = mysasu
        '客注名
            mymsg2 = "客注名を記入ください。"
            mytitle2 = "客注名"
            mykyaku = Application.InputBox(prompt:=mymsg2, _
                                                Title:=mytitle2, Type:=2)
            If mykyaku = "" Or mykyaku = False Then
                MsgBox "客注名が入力されていませんが、" & vbCrLf & _
                "客注名無しとして登録します。", vbExclamation, "FAX注文書作成"
                mykyaku = ""
            End If
            .Range("G" & nRow).Value = mykyaku
        '列幅自動調節
            .Columns("A:E").AutoFit
        End With
        With Worksheets("書誌データ貼付")
            .Activate
            .Range("A:F").Clear
            .Range("A1").Select
        End With
End Sub