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

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コード列の1つ右の列より小さければつまり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コード列の1つ右の列より小さければつまり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で読み込ませるのがよいでしょう。

ディスカッション
コメント一覧
まだ、コメントがありません