소개

Salesforce와 관련이 있지만 VBA 만 내용입니다.

Salesforce 인증 자격 보유자 수 기업별 목록이 게시되었습니다. 자격마다 매월 파일을 하나하나 보고 있는 것만으로는 그다지 의미 있는 정보를 얻을 수 없을지도 모르지만, 정리해 보면 뭔가 보일지도 모릅니다.

그래서 PDF 파일을 다운로드하고 PDF 파일의 자격 취득자 정보를 Excel로 가져오는 VBA 매크로를 만들어 보았습니다.

PDF 파일 다운로드 매크로에 대한 자세한 내용은 이전 기사 Salesforce 자격 취득자 수의 PDF 파일을 다운로드하는 매크로를 참조하십시오.

운영 환경

Windows 10의 Office365 (64bit)에서 확인합니다. 이전 Office에서는 작동하지 않을 수 있습니다.

팁

환경에 의존하는 것과 기본적인 내용은 스스로 해결해 주세요.
새 자격이 나오거나 삭제된 경우 자격 목록을 수정합니다.
PDF 파일의 구조가 바뀌어 버리거나 가져 오기가 실패했습니다. 문제가 발생하면 수정을 기다리거나 매크로를 수정하십시오.

기능 - 자격 취득자 수 다운로드

수식 - 이름 관리로 다운로드 폴더와 자격 목록의 위치가 정의되어 있으므로 확인하십시오.
자격 목록 시트의 B1 셀에 다운로드 된 파일이있는 폴더 이름을 씁니다.
(다운로드하지 않으면 "파일 다운로드"버튼으로 다운로드하십시오)
"PDF 파일 가져오기"버튼을 클릭하면 파일 가져오기가 시작됩니다.



Word를 사용하여 내용을 로드하므로 Word가 열립니다.



완료되면 메시지 상자가 표시됩니다.

수식의 이름으로 정의하고 있는 “자격 취득자수”를 바탕으로 피벗 테이블이나 그래프를 작성하면 여러가지 분석을 할 수 있다고 생각합니다




저는 디자이너 시험을 받는 순서대로 많은 수의 사람들을 선호했습니다.

매크로

'Copyright 2019 Yuji OKAZAKI
'
'Licensed under the Apache License, Version 2.0 (the "License");
'you may not use this file except in compliance with the License.
'You may obtain a copy of the License at
'
'    http://www.apache.org/licenses/LICENSE-2.0

'Unless required by applicable law or agreed to in writing, software
'distributed under the License is distributed on an "AS IS" BASIS,
'WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
'See the License for the specific language governing permissions and
'limitations under the License.

Option Explicit

Sub AppendNumOfCertHolder(w As Worksheet, ByRef r As Long, c As Long, strCompany As String, strDt As String, strCertName As String, strNum As String)
    w.Cells(r, c + 0).Value = strCompany
    w.Cells(r, c + 1).Value = strDt
    w.Cells(r, c + 2).Value = strCertName
    w.Cells(r, c + 3).Value = strNum
    r = r + 1
End Sub

Sub GetLastPosition(strName As String, ByRef w As Worksheet, ByRef r As Long, ByRef c As Long)
    Dim n As name
    Set n = ThisWorkbook.Names(strName)
    Dim rng As Range
    Set rng = n.RefersToRange

    Set w = rng.Worksheet
    c = rng.Column
    r = rng.Row + rng.Rows.Count
End Sub

Sub ResizeName(strName As String, w As Worksheet, r As Long, c As Long)
    Dim n As name
    Set n = ThisWorkbook.Names(strName) '"資格取得者数"
    Dim rng As Range
    Set rng = n.RefersToRange
    Dim rangeNew As Range
    Set rangeNew = rng.Worksheet.Range( _
                        rng.Worksheet.Cells(rng.Row, rng.Column), _
                        rng.Worksheet.Cells(r, rng.Column + rng.Columns.Count - 1))

    n.Delete
    ActiveWorkbook.Names.Add strName, rangeNew
End Sub
'wApp As Word.Application
Function ImportPDFFile(wApp, strDLFolder As String, rng As Range, w As Worksheet, r As Long, c As Long) As Boolean
    ImportPDFFile = False
    Dim strUrl As String
    Dim strFileName As String
    Dim strText As String
    '資格データは列番号で 1:略称 2:URL 3:ファイル名 4:分類 5:資格名 6:最終取得日
'    strFileName = strDLFolder + "\" + rng.Cells(1, 3)
    strUrl = rng.Cells(1, 2)
    If strDLFolder <> "" Then
        strFileName = strDLFolder + "\" + Mid(strUrl, InStrRev(strUrl, "/") + 1)
        If Dir(strFileName, vbNormal) = "" Then
            MsgBox "ファイルが見つかりません。以後の処理を終了します"
            Exit Function
        End If
    Else
        strFileName = strUrl
    End If

    Dim wDoc 'As Word.Document
    Set wDoc = wApp.Documents.Open(Filename:=strFileName, ConfirmConversions:=False, ReadOnly:=True)

    Dim wTbl 'As Word.Table
    '===========================================
    ' PDFファイルから日付の情報を取得します
    Dim dt As Date
    strText = Split(wDoc.Range.Text, vbCr)(1)
    If InStr(1, strText, "現在") > 0 Then '試験名が長い場合こちらに来る
        strText = Split(strText, "】" & vbTab)(1)
    Else '試験名が短い場合はこっちにくる
        strText = Split(wDoc.Range.Text, vbCr)(2)
        strText = Right(strText, Len(strText) - 1) '頭にごみがあるので削除
    End If
    If InStr(1, strText, "現在") <= 0 Then
        MsgBox "日付の取得に失敗しました。処理を中断します"
        Exit Function
    End If
    dt = DateValue(Split(strText, "現在")(0))
    If rng.Cells(1, 5) >= dt Then '最終取得日よりも新しいデータならデータを取得します
        MsgBox "最終取得日よりも古いデータでしたので，処理を終了します"
        wDoc.Close False
        Exit Function
    End If

    '===========================================
    Dim nRows As Integer
    Dim strCompany As String, strDt As String, strCertName As String, strNum As String
    strDt = FormatDateTime(dt, vbShortDate)
    strCertName = rng.Cells(1, 1)
    nRows = 0
    For Each wTbl In wDoc.Tables
        'テーブルとはページの切れ目みたい
        Dim wRow 'As Word.Row
        For Each wRow In wTbl.Rows
            '1行1行の処理
            If wRow.Cells.Count = 2 And _
               InStr(1, wRow.Cells(2).Range.Text, "名") > 0 Then
                '２列(社名,人数)データがあり、右に"名"がある場合のみデータを取得します
                strCompany = Trim(Split(wRow.Cells(1).Range.Text, vbCr)(0))
                strNum = Trim(Split(wRow.Cells(2).Range.Text, "名")(0))
                AppendNumOfCertHolder w, r, c, strCompany, strDt, strCertName, strNum
                nRows = nRows + 1
                DoEvents
            End If
        Next
    Next
    'Salesforce 認定 B2C Commerce Technical Solution デザイナー が表になってないので特別に
    If nRows = 0 Then
        Dim l As Variant
        Debug.Print wDoc.Range.Text
        For Each l In Split(wDoc.Range.Text, vbCr)
            If InStr(1, l, "資格保持者数") > 0 And Right(l, 1) = "名" Then
                ' 2020/01 ”企業名（ABC50音順） 資格保持者数”の次の行も同時に取れる
                l = Split(l, "資格保持者数")(1) ' ので前半を捨てる
            End If
            If InStr(1, l, vbTab) > 0 And Right(l, 1) = "名" Then
                strCompany = Split(Split(l, "名")(0), vbTab)(0)
                strNum = Split(Split(l, "名")(0), vbTab)(1)
                AppendNumOfCertHolder w, r, c, strCompany, strDt, strCertName, strNum
                DoEvents
            End If
        Next
    End If
    wDoc.Close False
    DoEvents
    rng.Cells(1, 5) = dt 'SFDCが情報を取得した時刻を設定
    ImportPDFFile = True
End Function

Sub ImportPDFFiles()
    Dim rng As Range
    Dim strDLFolder As String
    Dim fweb As Boolean
    fweb = False
    If fweb = False Then
        strDLFolder = ThisWorkbook.Names("ダウンロードフォルダ").RefersToRange.Cells(1, 1).Value
        If Dir(strDLFolder, vbDirectory) = "" Then
            MsgBox "ダウンロードフォルダが作成されていません"
            Exit Sub
        End If
    End If
    Dim wApp 'As Word.Application
    Set wApp = CreateObject("Word.application")
    wApp.Visible = True
    wApp.DisplayAlerts = False

    Dim rangeExam As Range
    Set rangeExam = ThisWorkbook.Names("Salesforce認定資格").RefersToRange

    Dim w As Worksheet, r As Long, c As Long
    GetLastPosition "資格取得者数", w, r, c

    For Each rng In rangeExam.Rows
        rng.Cells(1, 6) = ""
    Next

    For Each rng In rangeExam.Rows
        '資格の数だけのループを回る
        rng.Cells(1, 6) = "*"
        If ImportPDFFile(wApp, strDLFolder, rng, w, r, c) = False Then
            Exit For ' エラーがあったら中断する
            rng.Cells(1, 6) = "Error"
        End If
        rng.Cells(1, 6) = "完"
    Next
    ResizeName "資格取得者数", w, r - 1, c
    wApp.Quit False
    MsgBox "取り込み完了しました", vbOKOnly
End Sub

파일

Qiita에 파일을 첨부하는 방법을 모르기 때문에 Bitbucket에서
SF 자격 취득자 수.xlsm 다운로드