GoogleスプレッドシートをExcelで管理

2019年8月30日2019年10月28日

Googleフォームとスプレッドシート はWeb入力システムとして使うことができます。それを利用して、VBAを使って、 Googleスプレッドシートを、Excelのシートに格納してExcel側で一括処理することができます。

Option Explicit
'Google用紙在庫スプレッドシートを読み込み 2019/10/14
'------------------------------------------------------------------------------
'作表　EXCELのWebクエリの代用
'------------------------------------------------------------------------------
'①「読込」シートに読み込み
'②「在庫」シートに作表
Public Sub 作表()
    Dim 出力範囲 As Range
    Dim URLアドレス As String
    Dim msg As String
    Dim n As Long
    Dim 最終行 As Long
    Dim 最終行2 As Long
    Dim 比較 As Date
    Call FreezeExcel
    '①Googleスプレッドシートを読み込み
    Application.StatusBar = "①用紙在庫スプレッドシート読込 URL:" & ThisWorkbook.Sheets("設定").Range("B1").Value
    ThisWorkbook.Sheets("読込").Cells.ClearContents
    Set 出力範囲 = ThisWorkbook.Sheets("読込").Range("A1") 'データ出力セル指定
    URLアドレス = "URL;" & ThisWorkbook.Sheets("設定").Range("B1").Value '出力したいページのURL
    With 出力範囲.Parent.QueryTables.Add(Connection:=URLアドレス, Destination:=出力範囲) '出力
        .RefreshPeriod = 0 '自動タイマー更新を無効に
        .AdjustColumnWidth = False '列幅を自動調節しない
        .FillAdjacentFormulas = False 'クエリテーブルの右側の数式を自動的に更新しない
        .RefreshStyle = xlOverwriteCells 'セルのデータに上書き
        .WebFormatting = xlWebFormattingNone 'Webページの書式をインポートしない
        .BackgroundQuery = False 'クエリを非同期で実行しない
        .Refresh 'このメソッドを呼び出した時にデータソースと通信する
        .Delete '処理後にオブジェクトを削除
    End With
    Set 出力範囲 = Nothing
    '②空白行削除
    最終行 = ThisWorkbook.Sheets("読込").Cells(Rows.Count, 1).End(xlUp).row 'A列で行数確認
    With ThisWorkbook.Sheets("読込")
        For n = 最終行 To 1 Step -1
            If (.Cells(n, 1) = "") Or (.Cells(n, 3) = "") Then
                .Rows(n).Delete
            End If
        Next n
    End With
    '③「読込」シートのオートフィルターを解除
    With ThisWorkbook.Sheets("在庫")
        If .AutoFilterMode Then             ''オートフィルタが設定されていたら
            If .AutoFilter.FilterMode Then  ''絞り込みがされていたら
                .ShowAllData '絞り込み結果のみクリア
            End If
        End If
    End With
    '④「読込」シートを「在庫」シートの11行目以降に複写
    With ThisWorkbook.Sheets("読込")
        .Sort.SortFields.Clear
        .Sort.SortFields.Add Key:=Range("C2:C" & 最終行), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .Sort.SortFields.Add Key:=Range("A2:A" & 最終行), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        With .Sort
            .SetRange Range("A1:H" & 最終行)
            .Header = xlYes
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
        .Range(.Cells(2, 1), .Cells(最終行, 8)).Copy
        ThisWorkbook.Sheets("在庫").Range("A11").PasteSpecial Paste:=xlPasteValues
    End With
    Application.CutCopyMode = False
    Call 用紙情報取得
    msg = "読込完了"
    Call Googleエラーチェック
    Call MeltExcel
    MsgBox msg
End Sub
'------------------------------------------------------------------------------
'用紙情報取得取得　表示された用紙コードと設定シートの用紙情報を上表のC列以降に表示する
'------------------------------------------------------------------------------
Public Sub 用紙情報取得()
    Dim 格納列数 As Integer
    Dim n As Integer
    Dim i As Long
    Dim 最終列 As Integer
    Dim 最終行 As Long
    Dim msg
    Dim C As Range
    Dim ディクショナリ As Object
    Dim Rng As Range
    Call FreezeExcel
    格納列数 = 2
    Set ディクショナリ = CreateObject("Scripting.Dictionary")
    msg = ""
    With ThisWorkbook.Sheets("在庫")
        '最終列 = .Cells(1, Columns.Count).End(xlToLeft).Column '1行目で列数確認
        .Range(.Cells(1, 2), .Cells(8, 1000)).ClearContents '仮1000列までクリア
        '①用紙コード取得
        If .FilterMode = True Then 'オートフィルターモードで検索されている場合
            For Each C In .AutoFilter.Range.Columns(3).SpecialCells(xlCellTypeVisible)
                If (C.row > 10) Then '11行目以降がデータ
                    If Not ディクショナリ.Exists(C.Value) Then
                        ディクショナリ.Add C.Value, 1 '表示された用紙コードのみ格納
                        格納列数 = 格納列数 + 1
                        .Cells(1, 格納列数).Value = C.Value
                    End If
                End If
            Next C
        Else '検索されていない場合
            最終行 = .Cells(Rows.Count, 1).End(xlUp).row 'A列で行数確認
            For i = 11 To 最終行
                If Not ディクショナリ.Exists(.Cells(i, 3).Value) Then
                    ディクショナリ.Add .Cells(i, 3).Value, 1 '表示された用紙コードのみ格納
                    格納列数 = 格納列数 + 1
                    .Cells(1, 格納列数).Value = .Cells(i, 3).Value
                End If
            Next i
        End If
        '②用紙コードから用紙情報を検索表示
        最終行 = ThisWorkbook.Sheets("設定").Cells(Rows.Count, 1).End(xlUp).row 'A列で行数確認
        For n = 3 To 格納列数 '用紙コード格納行の列数
            With ThisWorkbook.Sheets("設定")
                Set Rng = .Range(.Cells(11, 1), .Cells(最終行, 1)).Find(What:=ThisWorkbook.Sheets("在庫").Cells(1, n).Value, LookIn:=xlValues, LookAt:=xlWhole)
                If Not Rng Is Nothing Then
                    ThisWorkbook.Sheets("在庫").Cells(2, n).Value = Rng.Offset(0, 1).Value
                    ThisWorkbook.Sheets("在庫").Cells(3, n).Value = Rng.Offset(0, 2).Value
                    ThisWorkbook.Sheets("在庫").Cells(4, n).Value = Rng.Offset(0, 3).Value
                    ThisWorkbook.Sheets("在庫").Cells(5, n).Value = Rng.Offset(0, 4).Value
                    ThisWorkbook.Sheets("在庫").Cells(6, n).Value = Rng.Offset(0, 5).Value
                    ThisWorkbook.Sheets("在庫").Cells(7, n).Value = Rng.Offset(0, 6).Value
                    ThisWorkbook.Sheets("在庫").Cells(8, n).Value = Rng.Offset(0, 7).Value
                End If
            End With
        Next n
    End With
    Set ディクショナリ = Nothing
    Call MeltExcel
End Sub
'------------------------------------------------------------------------------
'QRコード表示　QRコードの再表示に時間がかかるので、印刷直前に表示し、直後に消去する
'------------------------------------------------------------------------------
Public Sub QRコード表示()
    Dim 画像 As Shape
    Dim 最終行 As Integer
    Dim n As Integer
    Dim obj As Object
    Dim ボタン名 As String
    Dim nm As String
    Call FreezeExcel
    With ThisWorkbook.Sheets("設定")
        '参照を付ける
        AddIns("Makeqreps").Installed = True
        最終行 = .Cells(Rows.Count, 11).End(xlUp).row 'K列(QR数式)で行数確認
        For n = 11 To 最終行
            .Cells(n, 11).Formula = ""
        Next n
        最終行 = .Cells(Rows.Count, 1).End(xlUp).row 'A列(用紙コード)で行数確認
        For n = 11 To 最終行
            .Cells(n, 11).Formula = ""
            .Cells(n, 11).Formula = "=MakeQRCode(2,"""",1,0,5,5,$B$2,A" & n & ")"'ローラン　桜咲くさくQR使用
            .Rows(n).RowHeight = 70 'QRコードが表示される高さ
        Next n
    End With
    Call MeltExcel
    MsgBox "QRコード挿入完了"
End Sub
'------------------------------------------------------------------------------
'QRコード消去
'------------------------------------------------------------------------------
Public Sub QRコード消去()
    Dim 画像 As Shape
    Dim 最終行 As Integer
    Dim n As Integer
    Dim obj As Object
    Dim ボタン名 As String
    Dim nm As String
    With ThisWorkbook.Sheets("設定")
        最終行 = .Cells(Rows.Count, 1).End(xlUp).row 'A列(用紙コード)で行数確認
        For n = 11 To 最終行
            .Cells(n, 11).Formula = ""
        Next n
        For Each 画像 In ThisWorkbook.Sheets("設定").Shapes
            If (画像.Left < ThisWorkbook.Sheets("設定").Range("L11").Left) Then 'QRコード列の１つ右の列より小さければつまりQRコード列の画像なら
                画像.Delete
            End If
        Next 画像
        With ThisWorkbook.Sheets("設定")
            最終行 = .Cells(Rows.Count, 1).End(xlUp).row 'A列(用紙コード)で行数確認
            For n = 11 To 最終行
                .Cells(n, 11).Formula = ""
            Next n
        End With
    End With
    MsgBox "QRコード消去完了"
End Sub
'------------------------------------------------------------------------------
'アクティブシート上の図形を一括削除する
'------------------------------------------------------------------------------
Public Sub アクティブシート上の図形を一括削除する()
    Dim 画像 As Shape
    Dim 最終行 As Long
    Dim n As Long
    For Each 画像 In ThisWorkbook.Sheets("設定").Shapes
        If (画像.Left < ThisWorkbook.Sheets("設定").Range("L11").Left) Then 'QRコード列の１つ右の列より小さければつまりQRコード列の画像なら
            画像.Delete
        End If
    Next 画像
    With ThisWorkbook.Sheets("設定")
        最終行 = .Cells(Rows.Count, 1).End(xlUp).row 'A列(用紙コード)で行数確認
        For n = 11 To 最終行
            .Cells(n, 11).Formula = ""
        Next n
    End With
End Sub
'##############################################################################
'メソッド（プライベート）
'##############################################################################
'------------------------------------------------------------------------------
'Googleエラーチェック　前残と在庫の矛盾箇所を着色します
'------------------------------------------------------------------------------
Private Sub Googleエラーチェック()
    Dim 最終行 As Long
    Dim n As Long
    Dim 配列 As Variant
    Dim ecnt As Integer
    ecnt = 0
    With ThisWorkbook.Sheets("在庫")
        最終行 = .Cells(Rows.Count, 1).End(xlUp).row 'A列で行数確認
        .Range("A11:H" & 最終行).Interior.ColorIndex = 0
        配列 = .Range("A1:H" & 最終行) 'セルを丸ごと配列に格納し、比較
        For n = 11 To 最終行 - 1
            If (配列(n, 3) = 配列(n + 1, 3)) Then
                If (配列(n, 7) <> 配列(n + 1, 4)) Then '2行を比較し、用紙コードが同じ場合「在庫」と「前残」を比較、違えばエラーとして着色
                    .Cells(n, 7).Interior.ColorIndex = 3
                    .Cells(n + 1, 4).Interior.ColorIndex = 3
                    ecnt = ecnt + 2
                Else
                    If (配列(n, 7) = "") Then
                        .Cells(n, 7).Interior.ColorIndex = 3
                        ecnt = ecnt + 1
                    End If
                    If (配列(n, 4) = "") Then
                        .Cells(n, 4).Interior.ColorIndex = 3
                        ecnt = ecnt + 1
                    End If
                End If
            Else
                If (配列(n, 7) = "") Then
                    .Cells(n, 7).Interior.ColorIndex = 3
                    ecnt = ecnt + 1
                End If
                If (配列(n, 4) = "") Then
                    .Cells(n, 4).Interior.ColorIndex = 3
                    ecnt = ecnt + 1
                End If
            End If
        Next n
        If (配列(最終行, 7) = "") Then
            .Cells(最終行, 7).Interior.ColorIndex = 3
            ecnt = ecnt + 1
        End If
        If (配列(最終行, 4) = "") Then
            .Cells(最終行, 4).Interior.ColorIndex = 3
            ecnt = ecnt + 1
        End If
        '.Range("A1:H" & 最終行) = 配列 '処理後の配列を再格納
    End With
    If (ecnt > 0) Then
        MsgBox "前残と在庫の矛盾箇所を着色しました ecnt = " & ecnt & vbCrLf & "Googleスプレッドシートを確認して手直ししてください"
    End If
End Sub
'------------------------------------------------------------------------------
' is存在シート
'------------------------------------------------------------------------------
Function is存在シート(wb As Workbook, シート名 As String) As Boolean
    Dim ws As Worksheet
    On Error Resume Next
    Set ws = wb.Worksheets(シート名)
    If (ws Is Nothing) Then
        is存在シート = False
    Else
        is存在シート = True
        Set ws = Nothing
    End If
End Function
'------------------------------------------------------------------------------
' エクセルの自動機能停止
'------------------------------------------------------------------------------
Private Sub FreezeExcel()
    With Application
        .DisplayAlerts = False 'アラートの表示を停止
        .StatusBar = False 'ステータスバーの表示更新を停止
        .ScreenUpdating = False 'スクリーンの描画を停止
        .EnableEvents = False 'イベントを一時停止
        .Calculation = xlManual '計算を手動モードにする
    End With
End Sub
'------------------------------------------------------------------------------
' エクセルの自動機能再開
'------------------------------------------------------------------------------
Private Sub MeltExcel()
    With Application
        .Calculation = xlAutomatic '計算を自動モードに戻す
        .EnableEvents = True 'イベントを再開
        .ScreenUpdating = True 'スクリーンの描画を再開
        .StatusBar = True 'ステータスバーの表示を再開
        .DisplayAlerts = True 'アラートの表示を再開
    End With
End Sub

Googleスプレッドシート 側でGAS(GoogleAppsScript)で入出庫の基本的な処理を排他制御を使っておこなったデータを、EXCELVBAで読み込ませるのがよいでしょう。