商品情報をWebから収集する。エクセルVBAで入力データ作成

Option Explicit

Sub NOCSデータ登録()
    Dim nR As Long
    Dim L As Long, M As Long, kkkm As Variant, n As Long, kkk As Variant
    Dim spa As String, sp As String
        Worksheets("貼り付け").Select
        Worksheets("作業シート").Select
        If Range("B1").Value <> "書名" Then
            Range("A1").Value = "ISBN"
            Range("B1").Value = "書名"
            Range("C1").Value = "出版社"
            Range("D1").Value = "著者"
            Range("E1").Value = "本体価格"
        End If
        nR = Range("A1").CurrentRegion.Rows.Count + 1
        With Worksheets("貼り付け")
    '書名
            .Range("A1").Copy _
                Destination:=Worksheets("作業シート").Range("B" & nR)
    '出版社
            spa = Replace(.Range("B6"), "発行所=", "")
            sp = Replace(spa, "発売所=", "")
            Worksheets("作業シート").Range("C" & nR) = Trim(sp)
    '著者
            .Range("B7").Copy _
                Destination:=Worksheets("作業シート").Range("D" & nR)
    '本体価格
            L = Len(.Range("B8"))
            M = InStr(.Range("B8"), "体")
            kkkm = Right(.Range("B8"), L - M)
            n = InStr(kkkm, "円")
            kkk = Left(kkkm, n - 1)
            Worksheets("作業シート").Range("E" & nR) = kkk
    'ＩＳＢＮ
            .Range("B9").Copy _
                Destination:=Worksheets("作業シート").Range("A" & nR)
            Worksheets("作業シート").Range("A" & nR).NumberFormatLocal = "0_ "
            Worksheets("作業シート").Cells.EntireColumn.AutoFit
    '貼り付けシートの後処理
            .Range("A:F").Clear
            .Activate
        End With
        Range("A1").Select
End Sub

Sub 出版書誌データ登録Chrome()
    Dim hR, hAR As Long, nRr As Long
    Dim s As Long
    Dim tyoR As Long, ISR As Long, syuR As Long, prR, hakR As Long
    Dim tyo As String, pri As Long, pr As String, syu, red As String
    Dim ISa As Variant
    'コード冒頭
        Worksheets("貼り付け").Select
        hR = Cells(Rows.Count, 1).End(xlUp).Row
        hAR = ActiveCell.Row
        For s = 1 To hR
            If InStr(Range("A" & s), "著：") > 0 Then tyoR = s
            If InStr(Range("A" & s), "ISBN") > 0 Then ISR = s
            If InStr(Range("A" & s), "出版社") > 0 Then syuR = s
            If InStr(Range("A" & s), "定価") > 0 Then prR = s
            If InStr(Range("A" & s), "発売日") > 0 Then hakR = s
        Next s
        Worksheets("作業シート").Select
        If Range("B1").Value <> "書名" Then
            Range("A1").Value = "ISBN"
            Range("B1").Value = "書名"
            Range("C1").Value = "出版社"
            Range("D1").Value = "著者"
            Range("E1").Value = "本体価格"
            Range("F1").Value = "発売日"
        End If
        nRr = Range("A1").CurrentRegion.Rows.Count + 1
        On Error Resume Next
    '書名
        Worksheets("貼り付け").Range("A" & hAR).Copy _
            Destination:=Worksheets("作業シート").Range("B" & nRr)
    '出版社
        syu = Replace(Worksheets("貼り付け") _
                                .Range("A" & syuR), "出版社：", "")
        Worksheets("作業シート").Range("C" & nRr) = Trim(syu)
    '著者
        tyo = Replace(Worksheets("貼り付け") _
                                .Range("A" & tyoR), "著：", "")
        Worksheets("作業シート").Range("D" & nRr) = Trim(tyo)
    '本体価格
        pr = Replace(Worksheets("貼り付け") _
                            .Range("A" & prR), "円（本体）", "")
        pri = Replace(pr, "定価：", "")
        Worksheets("作業シート").Range("E" & nRr) = Trim(pri)
    'ＩＳＢＮ
        ISa = Replace(Worksheets("貼り付け") _
                                .Range("A" & ISR), "ISBN：", "")
        Worksheets("作業シート").Range("A" & nRr) = ISa
        Worksheets("作業シート").Range("A" & nRr) _
                                        .NumberFormatLocal = "0_ "
    '発売日
        red = Replace(Worksheets("貼り付け") _
                                .Range("A" & hakR), "発売日：", "")
        Worksheets("作業シート").Range("F" & nRr) = Trim(red)
        Worksheets("作業シート").Cells.EntireColumn.AutoFit
        On Error GoTo 0
        Worksheets("貼り付け").Range("A:A").Clear
        Worksheets("貼り付け").Activate
        Range("A1").Select
End Sub