集計を行うエクセルを作ったが、処理速度が遅いのでマクロを改善したい

Question

【やりたいこと】
googleアナリティクスのデータで、PV数ランキングを集計しています。

下記のようにパラメーターごとに別れて吐き出されるURLを

URLの重複を削除して流入項目ごとに集計したいです。

自分で作成した方法は、
①「?」でURLを分割し、関数でそれぞれの項目をカウント
②マクロで重複行を削除
③重複行を削除した行にカウントした数字を関数で引っ張ってくる
というものですが、動作が遅くて使い物になりません。

マクロの改善方法、もしくはそもそものやり方の改善方法を教えていただきたいです。
よろしくお願いします。

今のマクロは下記の通り

Sub 計算実行()
'
' 計算実行 Macro
'

'
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlManual
    
　Columns("A:A").Select
    Application.CutCopyMode = False
    Selection.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
        Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
        :="?", FieldInfo:=Array(Array(1, 1), Array(2, 1)), TrailingMinusNumbers:=True
    
　Application.Calculation = xlAutomatic
    Application.EnableEvents = True
    
    Application.EnableEvents = False
    Application.Calculation = xlManual
   
　 Sheets("重複削除").Select
    Columns("A:A").Select
    ActiveSheet.Range("$A$1:$A$1000”).RemoveDuplicates Columns:=1, Header:=xlNo
    Selection.Copy
    Sheets("結果ページ").Select
    Columns("A:A").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Rows("1:1").Select
    Application.CutCopyMode = False
    Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
    Range("H1").Range("A1").Copy Sheets("結果ページ").Range("A1:G1").Sheets("Sheet6")
    
　Application.Calculation = xlAutomatic
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub

張り付けシート

重複削除シート

結果ページシート

Comments

[stdio]

すみません、途中で下記のソースを行っている理由はなんですか？

Application.Calculation = xlAutomatic
Application.EnableEvents = True

Application.EnableEvents = False
Application.Calculation = xlManual

[Carol]

最初と最後だけに入れた時、動かなくなったため途中で入れました。
動かなかったのは全く別の原因だったのかもしれません。

[per_]

質問事項コード中のシートの名称が何種類かありますが、
どの画像はどのシートのもの、ということがわかるような情報をいただけますか？

ちなみにコードの中の"select"というコマンドは往々にして動作を重くするため
シートだったら select → activate というようにしていくと良いです。

[oikashinoa]

まずはどこが遅いかプロファイル取って調べてから会話しませんか？

回答も当てずっぽうになるだけですよ。

Answer 1

重複排除するよりグループ化集計してはどうでしょうか?
手順としては
(1)入力シートから以下の規則で中間ファイルにコピーする

• URLは「?」より前部分のみ切り出す。
• 「?」より後ろでPVを入力するカラムを決定

(2)中間ファイルを、

• URLをキーにソート
• URLをキーにグループ化。PV,ml,bunnerを合計

となります

おまけ。(1)を処理するコードサンプル。※コメント①②③を反映したもの

  Dim srcSH As Worksheet: Set srcSH = ThisWorkbook.Sheets("元")
  Dim dstSH As Worksheet: Set dstSH = ThisWorkbook.Sheets("中間シート")
  
  Dim eRx As Long: eRx = srcSH.Cells.SpecialCells(xlCellTypeLastCell).Row
  Dim wx As Long: wx = 1
  Dim rx As Long
  For rx = 2 To eRx
    Dim cx As Long: cx = 2
    Dim url As String: url = srcSH.Cells(rx, 1).Value
    If (url = "") Then GoTo SKIP01                                      ' 空白ならスキップ
    '
    ' urlの値によって処理を選択
    '
    Select Case (True)
      Case (InStr(url, "?s=") > 0): GoTo SKIP01                         ' スキップ(集計しない)
      Case (InStr(url, "?year=") > 0): cx = 2                           ' 値はPV欄へ。urlはそのまま。
      Case (InStr(url, "ml=") > 0): cx = 3:  url = Split(url, "?")(0)   ' 値はml欄へ。urlは?より前のみ
      Case (InStr(url, "side=") > 0): cx = 4: url = Split(url, "?")(0)  ' 値はbunner欄へ。urlは?より前のみ
    End Select
    wx = wx + 1
    dstSH.Cells(wx, 1) = url
    dstSH.Cells(wx, 2) = srcSH.Cells(rx, 2)      ' PVは常に設定
    dstSH.Cells(wx, cx) = srcSH.Cells(rx, 2)     ' 決定したカラムに値設定
SKIP01:
  Next rx
  '
  ' Sort (略)
  '
  ' グループ集計(略)。セル1をキーにしてグループ化しセル2､3､4の合計をとる
  '

Comments

[Carol]

①「中間ファイルにコピーする」の部分を私は関数で移していたのを、
書いていただいたコードサンプルで行う感じでしょうか？

②「元」シートと「中間シート」シートを作成するのでしょうか。

③Sub Macro3()
のようなマクロの名前（？）は適当につけて囲えばいいのでしょうか。

わからなすぎて申し訳ないです。
よろしければ教えていただけますと幸いです。

[h.horikoshi]

すいません、少し説明不足でした。

>①「中間ファイルにコピーする」の部分を私は関数で移していたのを、
>書いていただいたコードサンプルで行う感じでしょうか？

はい。

>②「元」シートと「中間シート」シートを作成するのでしょうか
>③Sub Macro3()
のようなマクロの名前（？）は適当につけて囲えばいいのでしょうか。

以下の手順となります。

(1)新規にExcelファイル(Book)を作成する。

(2)GoogleAnalyticsの結果をそのままの形で(1)のシートに展開する。これを「元」とする。

(3)新規のシートを(1)のbookに挿入する。これを「中間シート」とする。

(4)サンプルコードのマクロを作成する。
※たとえば「マクロの記録」を使って適当なマクロを作成したあと、その内容を
サンプルコードで置き換える。
(5)サンプルコードの
「元」「中間」のset文(1、2行目)を編集する。
Dim srcSH As Worksheet: Set srcSH = ThisWorkbook.Sheets("(2)のシート名を指定する")
Dim dstSH As Worksheet: Set dstSH = ThisWorkbook.Sheets("(3)のシート名を指定する")

(6)(4)で作成したマクロを実行する→これにより(2)が(3)にコピーされます。

(7)現状、サンプルにはSort、グループ集計は実装していませんので、
出力された(3)シートの内容に対し手動で編集を行なってください。
※それらも自動にしたい場合は、「マクロの記録」でSort、グループ集計の
コードを採取し、(4)に組み込んでください。

[Carol]

ご丁寧にありがとうございます。
かなり理想の動作に近くなっています。
グループ集計はマクロの記録でやってみたところ、スピード的にも問題ないので大丈夫そうです。

①ただ、実際のデータで実行すると、最初の段階↓で「インデックスが有効範囲にありません」エラーが出てしまいます。
dstSH.Cells(wx, 1) = Split(url, "?")(0) ' URL。?以降を除く
デバッグ中断してみると、処理自体は問題なくされているみたいなのですが、、、
１０行くらいのデータで実行するとエラーが出ません。

また、別の質問なのですが、
②データ内にはサイト内検索の結果URLも入っていて、
/?s=オリンピック
とかのPVが最終的にトップページのPVに集計されてしまいます。
考えた方法は、「s=」を含むものも　If (InStr(url,　あたりで集計して、合計から引く
という感じなのですが、これしか方法はないでしょうか。

③/?year=2020のように、ページ内でタブで切り替えて表示しているページがありました。
これは2020、2019、2018など別ページとして集計したいのですが、方法はあるでしょうか。
今は全てパラメーター部分をとっぱらったURLで集計されてしまいます。
これも年度ごとに集計だけしておいて、目視で確認するしかないでしょうか。

URLを"?"区切りで分ける方法自体がダメだったような気もしてきてしまいます。
もしよろしければ引き続きお付き合いいただけますと幸いです。

[h.horikoshi]

①
urlが空("")の行がないか確認してください。urlが空の場合
Splitの要素が全くないため、インデックス(0)の要素も読み
出せません。url=""の場合、その行の処理はスキップするよう
にしてください。

②
>「s=」を含むものも　If (InStr(url,　あたりで集計して、
>合計から引く
そうですね、「s=」も検出するならばif文を追加してください。
ただし、PVへの算入を除くには、結果の合計から引く必要はなく、
処理中に「s=」を検出した時点でその行の処理をスキップして
ください。

③
>これは2020、2019、2018など別ページとして集計したいのですが、
>方法はあるでしょうか。
これも②と同様if文を追加します。なお、このときはURLを分離しない
ようにします。

※①②③の対応版を回答のほうに反映しました。
>URLを"?"区切りで分ける方法自体がダメだったような気もしてきて
> しまいます。
Case文を増やせば、さらに切り分けの条件を指定できますが、
これでどこまで対応できるかは、どのようなバリエーションがあるか、
どのような集計をしたいかによりますので、当方では判断できません。

[Carol]

ご回答ありがとうございます。
サイト内検索・タブで切り替えのURL共に、利用通りの動作になりました。
これで完成としたいと思います。
なんども修正いただきありがとうございました。大変助かりました。
コードについては、もっと勉強してから書いていただいたのを読み返したいと思います。

Answer 2

回答の前に…
エクセルを開いた状態でAlt + F11を押すとエディターを開くことができます。
（質問者さんがマクロの結果をコピーした画面です）
実行したいSubにカーソルをおいた状態でF8キーを押すとコードを1行ずつ確認していくことができます。
各行がどんな動作をしているのか確かめながら書き換えていくと良いでしょう。
参考：マクロの編集の基本

ワークシートの関数は処理が重くなりがちなので
VBA上で計算して結果シートに貼り付けまで行えるようにしたほうが良いと思います。
項目数など実際にどれくらいの量があるかわからないので、配列の数字などは適宜変えてください。

質問に記載されている例であれば以下でまとまります。

Sub 項目ごとに集計()

Dim lastcol As Long 'データがあるシートのA列の一番したの行
Dim n As Long
Dim i As Long: i = -1
Dim j As Long: j = 0
Dim URLname As String

Dim pv(49, 3) As Variant
'2行4列の配列を作成します
'※配列は0番から始まります
'[URL]の種類が増えた分だけ行数を増やしてください
'[/topics/2019/]で1行、[/interview/2020/]で2行
'1列：URL名、2列：PV数、3列：ML、4列：バナー


　　'②：シート名称修正。データシートにはURLとPVの情報が載っているようにしてください。
    Sheets("データ").Activate
    lastcol = Sheets("データ").Range("A1").End(xlDown).Row

    Sheets("データ").Columns(2).Insert
    Sheets("データ").Range("A:A").TextToColumns Other:=True, OtherChar:="?"

    '2行目から記載されている最終行(1000行程度？)までくりかえし処理
    For n = 2 To lastcol
        If Cells(n, 1).Value <> Cells(n - 1, 1) Then
            URLname = Cells(n, 1).Value
            i = i + 1
            j = 0
            pv(i, j) = URLname
            j = j + 1

        End If
        pv(i, j) = Cells(n, 3).Value
        j = j + 1
    Next

    For i = 0 To UBound(pv)
        pv(i, 1) = pv(i, 1) + pv(i, 2) + pv(i, 3)
    Next

    Sheets("結果").Activate　　　　　'②：修正
    Range("A2").Resize(50, 4) = pv　'③：修正

End Sub

Comments

[Carol]

①項目はこれ以上ありません。行は１０００行だとすると、
Dim pv(999, 3) As Variant
'1000行4列の配列を作成します
になるのでしょうか。

②URLを分割した時に新しい列が挿入されるので、
「張り付けシート」の関数がうまく取れなくなってしまいます。
列がずれないようにするにはどうしたらいいのでしょうか。

③重複行の削除がうまくいっていないのか、最終的に/topics/2019/の1行だけ出てきます。
重複削除されているから１行になっているようでもあるし、でも/interview/2020/が消えてしまうのは何故なのか、、、

よろしければ教えていただけますと幸いです。

[per_]

①
"行"の意味が混ざってしまい恐縮ですが、この配列pv()の行列は
[/topics/2019/]で1行、[/interview/2020/]で2行…という感じで、重複を削除したあとの種類ごとに増やしてあげるという意味です。
取り急ぎは50種類程度としておきます。

②
ワークシートの関数を使わないで実現する方法を考えています。
混乱を避けるため、名称を変えてみました。
「データ」シートと「結果」シートを新しく作って試してみてください。

③
Range("A2").Value = pv
の部分に誤りがありました。

上記①～③に沿って回答を修正しましたので、再度おためしください。

[Carol]

引き続き回答いただきありがとうございます。

「データ」シートのA列にURL、B列にPVを入れて、
空の「結果」シートを作成。
実行したところ、下記で止まりました。

pv(i, j) = Cells(n, 3).Value
実行時エラー９
インデックスが有効範囲にありません
＿＿＿＿＿＿
pv(i, j) = Cells(n, 3).Value
j = j + 1
↑を消したところ（消しちゃダメだと思いますが）最後まで動きましたが、
重複の削除、メーリス・バナーPVの振り分けがうまくいかないようです、、、
なかなか難しいです、、、

[per_]

一番上の回答はすべて記載しなおしているので、もし一部だけ直しているようであれば再度コード全体をご確認ください。
おそらくjの値がpv(49, 3)の”3”からはみ出た値になってしまっていることが原因と思います。
[PV,ml,banner]以上の項目があると上記回答のコードではエラーになると思います。

`Dim pv(49, 3) As Variant` を `Dim pv(49, 10) As Variant` に書き換えてみてください。

Answer 3

意図が伝わって無いようなので、全部書き直します。

新規ブックの一番左のシートに以下をコピペ

  URL                                 PV                                                
  /topics/2019/                        100
  /topics/2019/?f2019ml*                10
  /topics/2019/?form*side_banner         1
  /interview/2020/                     200
  /interview/2020/?f2019ml*             20
  /interview/2020/?form*side_banner      2 

コードは、

Sub test()
    ThisWorkbook.Worksheets(1).Copy
    With Workbooks(Workbooks.Count)
        .Worksheets.Add after:=.Worksheets(1)
        With .Worksheets(1)
            .Activate               '←動作確認用（本番では不要）
            .Columns("B").Insert
            .Columns("A").TextToColumns Destination:=Range("A1"), OtherChar:="?"
            Application.DisplayAlerts = False
            .Range("A1").Subtotal GroupBy:=1, Function:=xlSum, TotalList:=3
            Application.DisplayAlerts = True
            .Outline.ShowLevels RowLevels:=2
            With .UsedRange
                .Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible).Copy
            End With
            With .Next
                .Activate               '←動作確認用
                .Paste Destination:=.Range("A1")
                .Columns("A").Replace What:=" 集計", Replacement:=""
                .Columns("B").Delete
                .UsedRange.EntireColumn.AutoFit
            End With
            Application.DisplayAlerts = False
            .Delete
            Application.DisplayAlerts = True
        End With
    End With
End Sub

※基本的に手動での操作を自動で行うように書いているだけだから、
手動でも1～2分くらいあれば出来るんじゃないでしょうか？
手動だと複雑な手順だと、手順を間違えることがあるのでマクロ化（作業の自動化）を
したいところですね＾＾

命令とかいちいち覚えてないので、
マクロの記録である程度コードを探って、
ヘルプで省略していい引数(無駄なことも記録される）や引数に何を入れたらいいか、
いろいろ確認して、
あとはコツとか不都合がある部分はネットを調べて、
プラス経験で完成させる感じです。（とにかく何度でも書いて動かしてみる。）

Comments

[Carol]

1000行程度で、１０数分かかってしまいます。
いただいたソースで試してみましたが、↓ここで止まってしまったようです。
.Subtotal GroupBy:=1, Function:=xlSum, TotalList:=3

[mattuwan]

エラーメッセージは出ませんか？

[Carol]

①いただいたままだと
実行時エラー1004
RangeクラスのSubtotalメソッドが失敗しました
となりました。

②最初のWith Worksheets("重複削除")を
With Worksheets("張り付けシート")
にしたところ最後まで動いて、分割や重複の削除などすごいいい感じでいけそうな気配がするのですが、
多分分割した時の列の挿入が原因（？）で関数でうまく数字が取れません。
・分割した後半のURLを既ににある列に入れる、
もしくは、
・挿入される列のセルを事前に選択する
ことはできるのでしょうか。

③あと、結果ページで重複削除ずみのURL一覧が入ってくるのはいいのですが、行の挿入になってしまうのか、隣の列に事前に関数を書いておいたところにPVなどの集計値が入りません。

よろしければ教えていただけますと幸いです。

[mattuwan]

事前に関数を入力する必要はありません。
新規のシートで提示のデータを入れて、
新規のシートに出力願います。
数式の量が半端無さそうですね＾＾；

[mattuwan]

説明がなかったので、こちらがシートを勘違いしているようですね。
元のデータと出力先用のシートを空で用意して実行してみてください。

[Carol]

引き続き回答いただきありがとうございます。

「重複削除」シートのA列にURL、B列にPVを入れて、その他の列は空、
空の「結果ページ」シートを作成。
実行でよいのでしょうか。

動かして見たところ、URLの分割やカウントはうまく言っているようで、
動きのスピードも良い感じです。
ただ、
/mytown/ 5833
/mytown/ 集計 5833
/mytown/ from=side_banner 5031
/mytown/ 集計 5031
今だとこのように↑出てくるものを、

　　　　　　　　合計　　　バナー
/mytown/　　　5833　　　 802
↑のように最終的に集計するにはどうするのが一番いいでしょうか。
＿＿＿＿＿＿＿＿
そもそも私が集計すのであればこのままでなんとか計算するのでもういいのですが、
別の作業者が自分で集計したいと言っているもので、、、

[mattuwan]

新しいシートに、結果がでてるはずですが？

Answer 4

スマホからなので簡単に。
…ここ数年vba触ってないのでボケてたらスミマセン。

重複排除で時間かかっているならいかが参考になると思います。
https://docs.microsoft.com/ja-jp/office/vba/excel/concepts/cells-and-ranges/delete-duplicate-entries-in-a-range

Comments

[Carol]

ありがとうございます。素人なもので難しいですが試してみます。