VBA 趣味プログラミングblog

ファイル一覧解析マクロ

2020年02月10日

今回は、フォルダ内のファイルの一覧をエクセルシートにするマクロ。

過去にファイル解析マクロをファイルシステムオブジェクトやDIR関数を使って
作ったものの、windowsのコマンドプロンプトで出せることを知った。

きっかけはこのページ。
https://www.excel-chunchun.com/entry/2019/01/03/184325

これに習って、DIR関数で作ってみたものの、
記載のとおり、環境依存文字がパスに含まれるとうまくいかない。

パート２でコマンドプロンプトを紹介していて、
ならそれでいいじゃんと思った次第。

ただ、コマンドプロンプトの結果をファイル出力しても
非常に使いづらいので出力結果ファイルを食って
結果をシートに吐き出すマクロを作った。

まずはコマンドプロンプトを起動。
WIndows+Rでウィンドウを開いて、cmdと入力してエンター。

次にコマンドを入力。
> DIR "フォルダパス" /A-D /S /B > "ファイル名"

これで、指定したフォルダ内のサブフォルダ(/S）を含めて、
フォルダ以外（/A-D)の情報を指定したファイル名（フルパス）に出力。
/B指定で、フルパスだけ出力してくれる。

/Bなしの場合

ドライブ D のボリュームラベルがありません。

ボリュームシリアル番号は C423-225F です

D:\Dropbox のディレクトリ

2015/03/11 22:08 10 .dropbox

2016/08/11 01:32 9,681 .picasa.ini

2014/03/29 00:10 6,945 0132777_20140329000950.csv

・
・
・

/Bありの場合

D:\Dropbox\.dropbox

D:\Dropbox\.picasa.ini

D:\Dropbox\0132777_20140329000950.csv

・
・
・

最初は/Bありの想定でマクロを作ってみたものの、
フルパスから更新日時やファイルサイズを取得するところでうまくいかず断念。

/Bなしは、必要な情報がすべてそろっているし、

「のディレクトリ」を含む行ならば、左辺を変数に格納するだけなので、意外と簡単に。

それが完成してから/Bありを見直したところ、
ファイルパスの最終文字に制御文字かなにかがはいっていたことが原因と判明。
両方のソースを完成できた。

ちなみに
/Bありは4225ファイルを平均３秒で出力
/Bなしは4224ファイルを平均１秒で出力

/Bなしは不要な情報がファイルにたくさん入っているものの、
/Bありのファイルから情報を取り出す処理のほうが当然重い結果でした。

Option Explicit

Sub ◆dir_ADSの解析()

' dir "D:\Dropbox\VBA" /s /a-d > "D:\Dropbox\VBA\dirout.txt"

Dim fPath As String: fPath = txtファイル名取得("DIR /A-D /Sの解析結果ファイルの選択")

If fPath = "" Then Exit Sub

Dim tictoc As Double

tictoc = Timer

'Debug.Print "[" & Now & "] "; Format(Timer - tictoc, "0.00秒")

Dim Dic: Set Dic = CreateObject("Scripting.Dictionary")

Dim buf As String, Path As String

Dim strDate As String, fSize As String, fname As String, Ext As String

'タイトル行作成

Dic.Add "FulName", "Folder" & "‡" & "File" & "‡" & "Date" & "‡" & "Size" & "‡" & "Ext"

Open fPath For Input As #1

Do Until EOF(1)

Line Input #1, buf

If Right(buf, Len("のディレクトリ")) = "のディレクトリ" Then

Path = Trim(Replace(buf, "のディレクトリ", ""))

ElseIf Mid(buf, 5, 1) = "/" And Mid(buf, 8, 1) = "/" Then

strDate = Replace(Trim(Mid(buf, 1, 17)), " ", " ")

fSize = Trim(Mid(buf, 19, 17))

fname = Trim(Mid(buf, 37, Len(buf) - 37 + 1))

Ext = 拡張子(fname)

Dic.Add Path & "\" & fname, AddressToLink(Path, ファイル名(Path)) & "‡" & fname & "‡" & strDate & "‡" & fSize & "‡" & Ext

End If

Loop

Close #1

Dim keys: keys = Dic.keys

Dim Items: Items = Dic.Items

Set Dic = Nothing

Dim Arr(): ReDim Arr(UBound(keys) + 1, 5)

Dim oBuf, i As Long, j As Long

For i = 0 To UBound(keys)

oBuf = Split(Items(i), "‡")

For j = 0 To UBound(oBuf)

Arr(i, j) = oBuf(j)

Next j

Next i

'出力

Worksheets.Add

Dim OutPutCell As Range: Set OutPutCell = Cells(1, 1)

Call ArrayToCell_1d_trns(OutPutCell, keys)

Call ArrayToCell_2d(OutPutCell.Offset(0, 1), Arr)

OutPutCell.Offset(1, 1).Select

ActiveWindow.FreezePanes = True 'ウィンドウ枠の固定ON

OutPutCell.AutoFilter

With ActiveSheet.AutoFilter.Range

.CurrentRegion.Borders.LineStyle = xlContinuous

End With

Dim OutPutRange As Range: Set OutPutRange = OutPutCell.Resize(UBound(keys) + 1, 1)

OutPutRange.Offset(1, 3).NumberFormatLocal = "yyyy/mm/dd hh:mm"

OutPutRange.Offset(1, 4).NumberFormatLocal = "#,##0"

Call ChangeSheetName("dirADS結果")

Cells(1, "H") = AddressToLink(fPath, fPath)

'Dim tictoc As Double

'tictoc = Timer

Debug.Print "[" & Now & "] "; Format(Timer - tictoc, "0.00秒")

End Sub

Sub ◆dirBファイルの解析()

Dim TextBuf As String: TextBuf = TextFileToBuf(txtファイル名取得("DIR /A-D /S /Bの解析結果ファイルの選択"))

If TextBuf = "" Then Exit Sub

Dim tictoc As Double

tictoc = Timer

'Debug.Print "[" & Now & "] "; Format(Timer - tictoc, "0.00秒")

Dim TextArray: TextArray = Split(TextBuf, Chr(10))

Dim TextLine As String, i As Long, cnt As Long: cnt = 1

Dim pPos As Long, yPos As Long, yPos2 As Long

Dim Arr(): ReDim Arr(UBound(TextArray), 5)

Arr(0, 0) = "テキスト"

Arr(0, 1) = "Folder"

Arr(0, 2) = "File"

Arr(0, 3) = "Date"

Arr(0, 4) = "Size"

Arr(0, 5) = "Ext"

On Error Resume Next 'ファイルがなかったりするので

For i = 1 To UBound(TextArray)

TextLine = Left(TextArray(i - 1), Len(TextArray(i - 1)) - 1)

Arr(i, 0) = TextLine ' "テキスト"

If Mid(TextLine, 2, 1) = ":" Then

pPos = InStrRev(TextLine, ".")

yPos = InStrRev(TextLine, "\")

yPos2 = InStrRev(Left(TextLine, yPos - 1), "\")

Arr(i, 1) = AddressToLink(Left(TextLine, yPos - 1), ファイル名(Left(TextLine, yPos - 1))) '"Folder"

Arr(i, 2) = Right(TextLine, Len(TextLine) - yPos) '"File"

Arr(i, 3) = FileDateTime(TextLine) ' "Date"

Arr(i, 4) = FileLen(TextLine) '"Size"

Arr(i, 5) = Right(TextLine, Len(TextLine) - pPos) '"Ext"

End If

Next i

'出力

Worksheets.Add

Call ArrayToCell_2d(Cells(1, 1), Arr)

Call ChangeSheetName("dirB結果")

Dim OutPutCell As Range: Set OutPutCell = Cells(1, 1)

OutPutCell.Offset(0, 3).NumberFormatLocal = "yyyy/mm/dd hh:mm"

OutPutCell.Offset(0, 4).NumberFormatLocal = "#,##0"

Call ArrayToCell_2d(OutPutCell, Arr)

Dim OutPutRange As Range: Set OutPutRange = OutPutCell.Resize(UBound(TextArray) + 1, 1)

OutPutRange.Offset(1, 3).NumberFormatLocal = "yyyy/mm/dd hh:mm"

OutPutRange.Offset(1, 4).NumberFormatLocal = "#,##0"

'Dim tictoc As Double

'tictoc = Timer

Debug.Print "[" & Now & "] "; Format(Timer - tictoc, "0.00秒")

End Sub

Private Sub ChangeSheetName(shName As String)

Dim flag As Boolean

If UsedSheetName(shName) = False Then

ActiveSheet.Name = shName

Exit Sub

End If

Dim cnt As Long: cnt = 2

Dim NewName As String: NewName = shName & " (" & cnt & ")"

Do While UsedSheetName(NewName) = True

cnt = cnt + 1

NewName = shName & " (" & cnt & ")"

Loop

ActiveSheet.Name = NewName

End Sub

Private Function UsedSheetName(shName As String) As Boolean

Dim ws As Worksheet, flag As Boolean

For Each ws In Worksheets

If ws.Name = shName Then flag = True

Next ws

UsedSheetName = flag

End Function

Private Sub ArrayToCell_1d_trns(Target As Range, oArr) '配列貼り付け便利モジュール

Dim iRowMax: iRowMax = UBound(oArr, 1) - LBound(oArr, 1) + 1

Dim iColMax: iColMax = 1 '１列データは転置が必要

Target.Resize(iRowMax, iColMax).Value = WorksheetFunction.Transpose(oArr)

End Sub

Function AddressToLink(Address As String, Caption As String) As String

AddressToLink = "=hyperlink(""" & Address & """,""" & Caption & """)"

End Function

Function Path2Link(Path As String) As String

Path2Link = "=Hyperlink(""" & Path & """,""" & Path & """)"

End Function

Function txtファイル名取得(Optional タイトル As String = "テキストファイルの選択", Optional デフォルト As String = "")

If デフォルト = "" Then

デフォルト = デスクトップパス

End If

Dim i As Long

'’https://excel-ubara.com/excelvba1/EXCELVBA376.html

Dim FSO: Set FSO = CreateObject("Scripting.FileSystemObject")

Dim FulName As String

With Application.FileDialog(msoFileDialogFilePicker)

.InitialFileName = デフォルト

.AllowMultiSelect = False

.Filters.Clear

.Filters.Add "テキストファイル", "*.txt"

.Filters.Add "すべてのファイル", "*.*"

.Title = タイトル

If .Show = True Then

FulName = .SelectedItems(1)

Else

MsgBox "キャンセルしました"

End If

End With

Set FSO = Nothing

txtファイル名取得 = FulName

End Function

Private Function ユーザー名取得()

Dim WshNetworkObject As Object

Set WshNetworkObject = CreateObject("WScript.Network")

ユーザー名取得 = WshNetworkObject.UserName

Set WshNetworkObject = Nothing

End Function

Private Function デスクトップパス()

Dim UserName As String

UserName = ユーザー名取得

デスクトップパス = "C:\Users\" & UserName & "\Desktop"

End Function

Sub ArrayToCell_2d(Target As Range, oArr, Optional ColCnt As Long = 0) '配列貼り付け便利モジュール

Dim iRowMax: iRowMax = UBound(oArr, 1) - LBound(oArr, 1) + 1 '// １次元目の要素数を取得 '// 二次元配列の最大行数

Dim iColMax: iColMax = UBound(oArr, 2) - LBound(oArr, 2) + 1 '// ２次元目の要素数を取得'// 二次元配列の最大列数

'// Rangeオブジェクトで開始セルから貼り付けるセル範囲を拡張する場合

If ColCnt > 0 And ColCnt <= iColMax Then

Target.Resize(iRowMax, ColCnt).Value = oArr

Else

Target.Resize(iRowMax, iColMax).Value = oArr

End If

End Sub

Function 拡張子(FileName As String) As String

Dim pPos As Long

pPos = InStrRev(FileName, ".")

If pPos <> 0 Then

拡張子 = Right(FileName, Len(FileName) - pPos)

Else

拡張子 = ""

End If

End Function

Function ファイル名(FileName As String) As String

Dim yPos As Long

yPos = InStrRev(FileName, "\")

If yPos <> 0 Then

ファイル名 = Right(FileName, Len(FileName) - yPos)

Else

ファイル名 = ""

End If

End Function

Function TextFileToBuf(FullName As String) As String

If FullName = "" Then Exit Function

Dim buf As String

With CreateObject("Scripting.FileSystemObject")

With .GetFile(FullName).OpenAsTextStream

buf = .ReadAll

.Close

End With

TextFileToBuf = buf

End Function

PR

Category・VBA | Comments(0)

フォルダ内のCSVファイルをエクセルシートに転記

2020年02月05日

今回はCSVファイルの転記について。

携帯電話の通話料に応じて費用按分をしているのだが、
回線ごとの通話料は利用明細を見ないとわからない。

仕方なく、回線ごとにシートを分けて利用明細をコピペしていたが、
いい加減めんどくさくなったので、
回線ごちゃまぜで１つのシートにまとめて
表計算で集計することにした。

ダウンロードしたデータのファイル名に回線名の記載がない。
同じデータを２つダウンロードしていても気づかないので
Dic配列を使って重複は排除することにした。

また例によって、オフィス田中氏のHPにお世話になりました。

'ファイルの一覧を取得

'http://officetanaka.net/excel/vba/file/file07.htm

'

'テキストファイルを読み込む

'http://officetanaka.net/excel/vba/file/file08b.htm

処理の流れは以下のとおり。

まず対象のフォルダを指定。今回は一発ものなので固定。

dir関数を使ってフォルダ内のファイルを取得。
対象ファイルがなくなるまでループ。

　dir関数で取得したファイルからフルパスを取得してファイルを開く。

　　各行のデータをDic配列に格納
　　（新出なら格納、既出なら値に目印を追加）

Dicの値をA列へ、キーをB列へ出力。

キー配列から区切り文字でsplitして、出力配列に格納。

C列以降に出力配列を格納。

そんな感じで、以下ソース。

Sub フォルダ内のCSVファイルを転記()

Const Path As String = "D:\Dropbox\xlsエクセル関連\IIJ 通話ログ\ログ\"

Const EXT = "*.csv"

Dim fName As String: fName = Dir(Path & EXT)

Dim Dic, buf As String

Set Dic = CreateObject("Scripting.Dictionary")

Do While fName <> ""

Open Path & fName For Input As #1

'ファイルを開いて

Do Until EOF(1)

Line Input #1, buf

If Not Dic.exists(buf) Then

Dic.Add buf, fName '新規キーを登録値は１

Else

Dic(buf) = Dic(buf) & "†" '既出のキーは、ファイル名に印

End If

Loop

Close #1

fName = Dir()

Loop

Dim Keys, Items

Keys = Dic.Keys

Items = Dic.Items

Dim iRowMax: iRowMax = UBound(Keys) - LBound(Keys) + 1

Cells(2, 1).Resize(iRowMax, 1).Value = WorksheetFunction.Transpose(Items) 'ファイル名

Cells(2, 2).Resize(iRowMax, 1).Value = WorksheetFunction.Transpose(Keys) 'CSVデータ（生）

Cells(1, 1) = "ファイル"

Cells(1, 2) = "CSV生データ"

Dim tmp: tmp = Split(Cells(2, 2), ",")

Dim iColMax: iColMax = UBound(tmp, 1) - LBound(tmp, 1)

Dim Arr(): ReDim Arr(iRowMax, iColMax)

Dim i As Long, j As Long

For i = 0 To UBound(Keys)

tmp = Split(Keys(i), ",")

For j = 0 To iColMax

Arr(i, j) = Replace(tmp(j), """", "")

Next j

Next i

Cells(2, 3).Resize(iRowMax, iColMax + 1).Value = Arr

End Sub

Category・VBA | Comments(0)

選択中のセルでオートフィルタ　他

2020年02月04日

今日はオートフィルタ。
みんな大好きオートフィルタ。

パソコンの操作は、マウスよりキーボードで処理したい派なので、
エクセルのオートフィルタを使うときはカーソル動かすのがめんどくさい。

なので、よく利用するオートフィルタ操作をマクロにして、
ショートカットキー登録をすると便利。

一番使う操作は、選択セルの内容でオートフィルタをする。

コマンドはめっちゃ簡単で、こんだけ。
myRange.AutoFilter field:=fColNo, Criteria1:=selection.text

myRangeはオートフィルタのアドレス。
fieldはオートフィルタ範囲で何列目で絞り込むか。
Criteria1は絞り込む内容。

オートフィルタの範囲、絞込みの有無は、以下で取得できる。（Office TANAKAより）
http://officetanaka.net/excel/vba/tips/tips129.htm

オートフィルタ範囲：ActiveSheet.AutoFilter.Range

絞込み有無：ActiveSheet.AutoFilter.Filters(fColNo).On

使ってみて思うこと。
①すでにその列でフィルタ済みだったら解除したい。
②オートフィルタ外の列だったらオートフィルタの範囲を変えたい。
③データがないのにオートフィルタしないで欲しい。
④他の条件での絞り込みもしたい。
　ア　選択したセル以外で絞込み
　イ　選択したセルの内容を含むセルで絞込み
　ウ　クリップボードの内容を含むセルで絞込み
　エ　空白でなく、０でもないセルで絞込み

今回は、上記に対応したソースを掲載します。
絞込み条件は、Criteria1で指定するだけなので、共通モジュールを用意して、
各プロシージャから呼び出す方法にしました。

Sub ▼選択オートフィルタ()

Dim fText1 As String: fText1 = Format(Selection(1).Value, Selection(1).NumberFormatLocal)

Call オートフィルタ共通モジュール(fText1)

End Sub

Sub ▼選択以外でオートフィルタ()

Dim fText1 As String: fText1 = "<>" & Format(Selection(1).Value, Selection(1).NumberFormatLocal)

Call オートフィルタ共通モジュール(fText1)

End Sub

Sub ▼検索オートフィルタ()

Dim fText1 As String: fText1 = "*" & Format(Selection(1).Value, Selection(1).NumberFormatLocal) & "*"

Call オートフィルタ共通モジュール(fText1)

End Sub

Sub ▼クリップボードオートフィルタ()

Dim fText1 As String: fText1 = "*" & GetCB & "*"

Call オートフィルタ共通モジュール(fText1)

End Sub

Sub ▼空白と0以外でオートフィルタ()

Dim fText1 As String: fText1 = "<>"

Dim fText2 As String: fText2 = "<>0"

Call オートフィルタ共通モジュール(fText1, fText2)

End Sub

Private Function GetCB() As String

'クリップボードから文字列を取得

'https://www.ka-net.org/blog/?p=7537

With CreateObject("Forms.TextBox.1")

.MultiLine = True

If .CanPaste = True Then .Paste

GetCB = .Text

End With

End Function

Private Sub オートフィルタ共通モジュール(fText1 As String, Optional fText2 As String = "")

If ActiveSheet.AutoFilter Is Nothing Then '<>""ではなく、Nothing

' MsgBox "オートフィルタを設定してください。"

' Exit Sub

If MsgBox("選択セルでオートフィルタを実行します", vbOKCancel) = vbOK Then

Selection.AutoFilter

Else

Exit Sub

End If

Dim myRange As Range: Set myRange = ActiveSheet.AutoFilter.Range

Dim Flag_nodata As Boolean

If Cells(Rows.Count, Selection.Column).End(xlUp).Row = 1 And Cells(1, Selection.Column) = "" Then

Flag_nodata = True

Else

Flag_nodata = False

End If

Dim RC As Long

If Selection.Column > myRange(myRange.Count).Column Then ' 列が範囲より右なら

If Flag_nodata = True Then Exit Sub

RC = MsgBox("オートフィルタ外のため範囲を拡張します（再設定）", vbOKCancel, "オートフィルタ範囲拡張の有無")

If RC <> vbOK Then Exit Sub 'キャンセルなら拡張せずに終了

myRange.AutoFilter '一旦オートフィルタを解除

Set myRange = myRange.Resize(, Selection.Column - myRange.Column + 1) 'フィルタ列を選択範囲まで右側に拡張

myRange.AutoFilter

ElseIf Selection.Column < myRange.Column Then

If Flag_nodata = True Then Exit Sub

RC = MsgBox("オートフィルタ外のため範囲拡張します（再設定）", vbOKCancel, "オートフィルタ範囲拡張の有無")

If RC <> vbOK Then Exit Sub 'キャンセルなら拡張せずに終了

myRange.AutoFilter '一旦オートフィルタを解除

Set myRange = Cells(myRange.Row, Selection.Column).Resize(myRange.Rows.Count, myRange.Columns.Count + myRange.Column - Selection.Column) 'フィルタ列を選択範囲まで左側に拡張

myRange.AutoFilter

End If

Dim fColNo As Long: fColNo = Selection.Column - myRange.Column + 1 'フィルタ範囲の何番目の列か

'https://www.moug.net/tech/exvba/0030004.html

If ActiveSheet.AutoFilter.Filters(fColNo).On Then '選択中の列が絞り込まれているなら列フィルタ解除

myRange.AutoFilter field:=fColNo

Else

'絞り込まれてないなら

If Cells(Rows.Count, Selection.Column).End(xlUp).Row = 1 And Cells(1, Selection.Column) = "" Then

'MsgBox "列にデータがありません。終了します。"

Exit Sub

Else

'列にデータがあるのでフィルタする

If fText2 = "" Then

myRange.AutoFilter field:=fColNo, Criteria1:=fText1

Else

myRange.AutoFilter field:=fColNo, Criteria1:=fText1, Criteria2:=fText2, Operator:=xlAnd

End If

End Sub

2023/11/5 追記・修正列幅が狭くて＃＃＃＃＃と表示されていてもオートフィルタができるようソースコード内のフィルタ条件を以下の通り変更しました。

2023/11/13 追記内容を修正。標準書式でエラーが出ないよう、列幅が狭くて＃＃＃＃＃と表示されている場合とその他の場合を分けた。

変更前
Selection(1).Text

変更後
if Left(Selection(1).Text ,1) = "#" then
　Format(Selection(1).Value, Selection(1).NumberFormatLocal)
else
　Selection(1).Text
end if

詳細については、以下の記事を参照。
「選択オートフィルタの改良と標準機能について～.textの列幅エラー対策～」

Category・VBA | Comments(0)

アパッチのWEBアクセスログの集計⑤

2020年02月03日

アパッチのWEBアクセスログをエクセルVBAで集計したい。

今回は５回目。前回やろうとしたstep2について。

やりたいこと

step1．フォルダ内の全ファイルを対象としたループを作る

step2．各ファイル内のデータを日付別にシート出力

step3．各シートで、ログデータを区切る

step4．区切られたデータを集計

過去ログ
①やりたいことの整理
②step3
③step3やり直し
④step4

前回書いたとおり、dictionary配列を使用。
この配列の利便性がやばい。

ログデータの日付文字列をキーとした配列を作って、
値として、行のデータをつなげていけばよさそう。

Dim Dic, i As Long, buf As String, Keys

Set Dic = CreateObject("Scripting.Dictionary")

For i = TGyo + 1 To GyoEnd

buf = Cells(i, Col).Value　　　’Colは日付データの列

If Not Dic.Exists(buf) Then

Dic.Add buf, cells(i,1).value

Else

Dic(buf) = Dic(buf) & cells(i,1).value

End If

Next i

今回は、手動で作業してしまったので、ここまで。

Category・VBA | Comments(0)

アパッチのWEBアクセスログの集計④

2020年01月14日

アパッチのWEBアクセスログをエクセルVBAで集計したい。

step1．フォルダ内の全ファイルを対象としたループを作る

step2．各ファイル内のデータを日付別にシート出力

step3．各シートで、ログデータを区切る

step4．区切られたデータを集計

前回step3を汎用性もたせて作り直した結果遅くなった。

今回はstep2を検討したら、step4のネタが思いつきました。

日付ごとにシートを分けるための処理。

まず、ログデータの日付情報は[の後の11文字が対象。
[の位置を検索して、次の文字から11文字をmidで取ればOKだね。

問題となるのは、新出のデータなら新しいシートに、
既出のデータなら既存のシートに出力する必要があること。

シート一覧を作ろうとすると、重複のしないリストを作る処理になるので、
検索してみた。

参考ページ（いつもお世話になってるオフィスOffice TANAKA）
http://officetanaka.net/excel/vba/tips/tips80.htm

重複しないリスト作りとして５つ紹介されてますが、
高速処理なVBAという観点で考えると（１）か（２）か。
（１）Dictionaryオブジェクト（連想配列）
（２）コレクション

前回作ったログデータをもとにIPアドレスやUAなどを集計したところ、
（２）のコレクションのほうが若干速い結果になった。

条件を変えて、全セルをユニークデータにしたところ、以下のとおり逆転。
（１）１０万行を１０秒
（２）１０万行を５０秒

高速に重複チェックをできるなら、カウントも入れればstep4で使えるじゃんってことで、
先にstep4をやることにした。

列のデータを配列に格納して、ユニークデータに対するカウント数を出力するマクロ。
ソースはこちら。

Sub 列集計_配列型()

'大文字小文字区別　空欄対応

Dim tictoc As Double

tictoc = Timer

Dim Col As Long: Col = Selection.Column

Dim Gyo As Long, GyoEnd As Long, TGyo As Long, ColName As String

If Cells(1, Col) <> "" Then

TGyo = 1

Else

TGyo = Cells(1, Col).End(xlDown).Row

End If

ColName = Cells(TGyo, Col).Text

GyoEnd = Cells(Rows.Count, Col).End(xlUp).Row

If GyoEnd = 1 Then

MsgBox "データがありません"

Exit Sub

End If

Dim Dic, i As Long, buf As String, Keys

Set Dic = CreateObject("Scripting.Dictionary")

For i = TGyo + 1 To GyoEnd

buf = Cells(i, Col).Value

If Not Dic.Exists(buf) Then

Dic.Add buf, 1

Else

Dic(buf) = Dic(buf) + 1

End If

Next i

''出力

Worksheets.Add

Dim oArr() As Variant

ReDim oArr(Dic.Count + 1, 2)

oArr(0, 0) = "№"

oArr(0, 1) = ColName

oArr(0, 2) = "カウント"

Keys = Dic.Keys

For i = 0 To Dic.Count - 1

oArr(i + 1, 0) = i + 1

oArr(i + 1, 1) = Keys(i)

oArr(i + 1, 2) = Dic(Keys(i))

Next i

Set Dic = Nothing

Dim NoCell As Range

Set NoCell = Cells(2, 1)

Call ArrayToCell(NoCell, oArr)

NoCell.AutoFilter

With ActiveSheet.AutoFilter.Range

.Sort Key1:=.Range("C2"), Order1:=xlDescending, Header:=xlYes

End With

Cells(1, 1) = Format(i, "#,##0種")

Cells(1, 2) = "合計："

Cells(1, 3) = Format(GyoEnd - TGyo, "#,##0件")

On Error Resume Next

ActiveSheet.Name = ColName & "_内訳"

Call ArrayToCell(NoCell, oArr, 1) ' №の入った１列目だけ再出力

'Debug.Print "[" & Now & "] "; Format(GyoEnd - 1, "#,##0行を") & Format(Timer - tictoc, "0.00秒")

End Sub

Sub ArrayToCell(Target As Range, oArr, Optional ColCnt As Long = 0) '配列貼り付け便利モジュール

Dim iRow '// データ設定用の行カウンタ

Dim iCol '// データ設定用の列カウンタ

Dim iRowMax '// 二次元配列の最大行数

Dim iColMax '// 二次元配列の最大列数

'// １次元目の要素数を取得

iRowMax = UBound(oArr, 1) - LBound(oArr, 1) + 1

'// ２次元目の要素数を取得

iColMax = UBound(oArr, 2) - LBound(oArr, 2) + 1

'// Rangeオブジェクトで貼り付けるセル範囲を指定する場合

'Range(Cells(1, 1), Cells(iRowMax, iColMax)).Value = oArr

'// Rangeオブジェクトで開始セルから貼り付けるセル範囲を拡張する場合

If ColCnt > 0 And ColCnt <= iColMax Then

Target.Resize(iRowMax, ColCnt).Value = oArr

Else

Target.Resize(iRowMax, iColMax).Value = oArr

End If

End Sub

列データ集計は業務上使用頻度が高く、結構便利なモジュール。
重複のないリストを作るだけであれば、Dic.Exists(buf)の判定処理は不要だが
今回はカウント処理をするために残した。
Dictionaryオブジェクトでは、キーデータはユニークである必要
試した結果、キーはブランクOK。大文字小文字の区別あり。

Category・VBA | Comments(0)

趣味プログラミングblog

ファイル一覧解析マクロ

フォルダ内のCSVファイルをエクセルシートに転記

選択中のセルでオートフィルタ　他

アパッチのWEBアクセスログの集計⑤

アパッチのWEBアクセスログの集計④

プロフィール

カテゴリー

最新記事

RSS

リンク

P R

趣味プログラミングblog

ファイル一覧解析マクロ

フォルダ内のCSVファイルをエクセルシートに転記

選択中のセルでオートフィルタ 他

アパッチのWEBアクセスログの集計⑤

アパッチのWEBアクセスログの集計④

プロフィール

カテゴリー

最新記事

RSS

リンク

P R

選択中のセルでオートフィルタ　他