【VBA+Chromedriver】URLエンコード 64bit対応

Public Sub Sample()
MsgBox EncodeURL(“キーワード”)
End Sub

Private Function EncodeURL(ByVal sWord As String) As String
Dim d As Object
Dim elm As Object

sWord = Replace(sWord, “\”, “\”)
sWord = Replace(sWord, “‘”, “\'”)
Set d = CreateObject(“htmlfile”)
Set elm = d.createElement(“span”)
elm.setAttribute “id”, “result”
d.body.appendChild elm
d.parentWindow.execScript “document.getElementById(‘result’).innerText = encodeURIComponent(‘” & sWord & “‘);”, “JScript”
EncodeURL = elm.innerText

End Function

【VBA+Chromedriver】画像アドレス取得

For k = 2 To row01 ‘画像アドレス取得

chk = Cells(k, 4).Value ’画像を探すページアドレスの一覧

 driver.Get (chk)

Set elements = driver.FindElementsByTag("img") ’ページから imgタグのある要素一気に抜き出し

For i = 1 To elements.Count
'リンクURLを収集する
aLink = elements.Item(i).Attribute("src")

‘ atitl = elements.Item(i).Text

  If InStr(aLink, "https://m.media-amazon.com") <> 0 And InStr(aLink, "UL320") <> 0 Then ’抜き出された画像ドレスに色々条件つけて確定




    sh01.Cells(k, 5).Value = aLink


Exit For

  End If
Next i

【Excel-VBA】画像のみ選択して(削除)

Function imgdel() ‘画像のみ一括選択する
Dim chkBox As Excel.CheckBox
Dim objShape As Object
Dim arr() As String
ReDim Preserve arr(0)
Dim sh01 As Worksheet
Set sh01 = Worksheets(“キーワード一覧”)

'選択シートに存在するオブジェクトを取得します。
For Each objShape In sh01.Shapes

    arr(UBound(arr)) = objShape.Name

    'オブジェクトのタイプが画像であるか判定します。
    If objShape.Type = 11 Then ’リンク画像 11

        '画像オブジェクトの名前を配列に追加します。
        arr(UBound(arr)) = objShape.Name

        '値を保持したまま配列を最大インデックスを追加します。
        ReDim Preserve arr(UBound(arr) + 1)

    End If

Next

'空の値を削除します。
If UBound(arr) > 0 Then
ReDim Preserve arr(UBound(arr) - 1)

'画像オブジェクトを選択します。
sh01.Shapes.Range(arr).Select

'選択オブジェクトを削除します。
Selection.Delete
End If

End Function

選択する種別を変更

msoAutoShape 図形/オートシェイプ 1
msoCallout 吹き出し 2
msoChart グラフ 3
msoComment コメント 4
msoGroup グループ化された図形 6
msoLinkedPicture リンク画像 11
msoPicture 画像 13
msoTextBox テキストボックス 17
msoTable 表 19

【Excel-VBA】画像URLからサムネイルをエクセルシートに張り付ける

Function URLPictureInsert() ‘画像インポート 画像アドレスが必要

Dim Pshp As Shape
Dim xRg As Range
Dim xCol As Long
On Error Resume Next

Dim sh01 As Worksheet
Set sh01 = Worksheets(“キーワード一覧”)

‘Application.ScreenUpdating = False

row01 = sh01.Cells(Rows.Count, 1).End(xlUp).Row ‘最終行

Set Rng = sh01.Range(“E2:E” & row01)’ここに画像アドレスを入れる
For Each Cell In Rng
filenam = Cell
ActiveSheet.Pictures.Insert(filenam).Select
Set Pshp = Selection.ShapeRange.Item(1)
If Pshp Is Nothing Then GoTo lab
xCol = Cell.Column + 1
Set xRg = Cells(Cell.Row, xCol)
With Pshp
.LockAspectRatio = msoFalse
If .Width > xRg.Width Then .Width = xRg.Width * 2 / 3
If .Height > xRg.Height Then .Height = xRg.Height * 2 / 3
.Top = xRg.Top + (xRg.Height – .Height) / 2
.Left = xRg.Left + (xRg.Width – .Width) / 2
End With
lab:
Set Pshp = Nothing
Range(“A2”).Select
Next
‘Application.ScreenUpdating = True
End Function

【Excel-VBA】辞書関数を使って重複を除外してカウントする

Sub tyuumosuu() ‘件数カウント 注文番号重複除外
Dim i As Long
Dim j As Long
Dim maxRow As Long

Dim strMat, lngNum
Dim sh1 As Worksheet
Set sh1 = Worksheets(“未出荷レポート”)
Dim sh2 As Worksheet
Set sh2 = Worksheets(“出荷表”)
Dim dic
Set dic = CreateObject(“Scripting.Dictionary”)

lrwo = sh1.Cells(Rows.Count, 1).End(xlUp).Row ‘最終行

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual ‘自動計算停止(手動計算)

j = 2 ‘リスト書き出し開始行

maxRow = sh1.Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To maxRow
    strMat = sh1.Cells(i, 1).Value


    If dic.Exists(strMat) Then’重複してたら何もしない

    Else
        dic.add (sh1.Cells(i, 1).Value), j’重複してなければデータ追加
        j = j + 1
    End If
Next i

sh2.Cells(3, 3).Value = “注文件数 ” & j – 2 & “件 出荷個数”

Application.Calculation = xlCalculationAutomatic '自動計算開始
Application.ScreenUpdating = True '画面描画再開

End Sub

【Excel-VBA】配列変数を使って大量のデータを一気に処理する

最初の配列MyArray1でデータを変数内にまとめて納めるMyArray1 = Range(“A2:C” & row01) もう一つの配列に結果を納めるReDim MyArray2(1 To row01, 1 To 2) 最後に範囲指定した場所に一気に放り込むRange(“D2:E” & row01) = MyArray2

Sub tesut02()
Dim i As Long
Dim MyArray1
Dim MyArray2
Dim sh01 As Worksheet
Set sh01 = Worksheets(“メーカー在庫まとめ”)
row01 = sh01.Cells(Rows.Count, 2).End(xlUp).Row ‘最終行

MyArray1 = Range(“A2:C” & row01)
ReDim MyArray2(1 To row01, 1 To 2)

For i = LBound(MyArray1, 1) To UBound(MyArray1, 1)
    MyArray2(i, 1) = MyArray1(i, 1) & "M" & MyArray1(i, 2)
    MyArray2(i, 2) = MyArray1(i, 3)
Next

Range(“D2:E” & row01) = MyArray2